From 95b43cbcc4390d9058034b769ffa757c42d2a74f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 20:02:11 +0200 Subject: new instructions at asm level --- mppa_k1c/Asm.v | 24 ++++++++++++++ mppa_k1c/Asmblockdeps.v | 14 +++++++- mppa_k1c/Asmvliw.v | 54 ++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++ mppa_k1c/TargetPrinter.ml | 62 ++++++++++++++++++++++++++++++++---- 5 files changed, 157 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1774b102..6a4095da 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -182,7 +182,9 @@ Inductive instruction : Type := | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Psubxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) | Pmulw (rd rs1 rs2: ireg) (**r mul word *) | Pandw (rd rs1 rs2: ireg) (**r and word *) | Pnandw (rd rs1 rs2: ireg) (**r nand word *) @@ -197,9 +199,12 @@ Inductive instruction : Type := | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : Z) (rd rs1 rs2: ireg) (**r add long shift *) | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Psubxl (shift : Z) (rd rs1 rs2: ireg) (**r sub long shift *) | Pandl (rd rs1 rs2: ireg) (**r and long *) | Pnandl (rd rs1 rs2: ireg) (**r nand long *) | Porl (rd rs1 rs2: ireg) (**r or long *) @@ -214,6 +219,7 @@ Inductive instruction : Type := | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) @@ -226,6 +232,9 @@ Inductive instruction : Type := | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : Z) (rd rs: ireg) (imm: int) (**r add imm word *) + | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Psubxiw (shift : Z) (rd rs: ireg) (imm: int) (**r subtract imm word *) | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) @@ -249,6 +258,9 @@ Inductive instruction : Type := (** Arith RRI64 *) | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : Z) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Psubxil (shift : Z) (rd rs: ireg) (imm: int64) (**r subtract imm long *) | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) @@ -338,7 +350,9 @@ Definition basic_to_instruction (b: basic) := | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Psubxw shift) rd rs1 rs2 => Psubxw shift rd rs1 rs2 | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 @@ -354,7 +368,9 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Psubxl shift) rd rs1 rs2 => Psubxl shift rd rs1 rs2 | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 @@ -379,6 +395,9 @@ Definition basic_to_instruction (b: basic) := (* RRI32 *) | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Psubiw rd rs imm => Psubiw rd rs imm + | PArithRRI32 (Asmvliw.Psubxiw shift) rd rs imm => Psubxiw shift rd rs imm | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm @@ -401,6 +420,9 @@ Definition basic_to_instruction (b: basic) := (* RRI64 *) | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Psubil rd rs imm => Psubil rd rs imm + | PArithRRI64 (Asmvliw.Psubxil shift) rd rs imm => Psubxil shift rd rs imm | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm @@ -414,6 +436,8 @@ Definition basic_to_instruction (b: basic) := (** ARRR *) | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index eb3900d5..82062fab 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1405,12 +1405,14 @@ Definition string_of_name_rf64 (n: arith_name_rf64): pstring := Definition string_of_name_rrr (n: arith_name_rrr): pstring := match n with - Pcompw _ => "Pcompw" + | Pcompw _ => "Pcompw" | Pcompl _ => "Pcompl" | Pfcompw _ => "Pfcompw" | Pfcompl _ => "Pfcompl" | Paddw => "Paddw" + | Paddxw _ => "Paddxw" | Psubw => "Psubw" + | Psubxw _ => "Psubxw" | Pmulw => "Pmulw" | Pandw => "Pandw" | Pnandw => "Pnandw" @@ -1425,7 +1427,9 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Psrxw => "Psrxw" | Psllw => "Psllw" | Paddl => "Paddl" + | Paddxl _ => "Paddxl" | Psubl => "Psubl" + | Psubxl _ => "Psubxl" | Pandl => "Pandl" | Pnandl => "Pnandl" | Porl => "Porl" @@ -1451,6 +1455,9 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" + | Psubiw => "Psubiw" + | Paddxiw _ => "Paddxiw" + | Psubxiw _ => "Psubxiw" | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" @@ -1475,6 +1482,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" + | Psubil => "Psubil" + | Paddxil _ => "Paddxil" + | Psubxil _ => "Psubxil" | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" @@ -1490,6 +1500,8 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := match n with | Pmaddw => "Pmaddw" | Pmaddl => "Pmaddl" + | Pmsubw => "Pmsubw" + | Pmsubl => "Pmsubl" | Pcmove _ => "Pcmove" | Pcmoveu _ => "Pcmoveu" end. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 3bef1a5c..e8ea4318 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -429,7 +429,9 @@ Inductive arith_name_rrr : Type := | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) - | Psubw (**r sub word *) + | Paddxw (shift : Z) (**r add shift *) + | Psubw (**r sub word word *) + | Psubxw (shift : Z) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -445,7 +447,9 @@ Inductive arith_name_rrr : Type := | Psllw (**r shift left logical word *) | Paddl (**r add long *) + | Paddxl (shift : Z) (**r add shift long *) | Psubl (**r sub long *) + | Psubxl (shift : Z) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -472,6 +476,9 @@ Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) + | Paddxiw (shift : Z) + | Psubiw (**r add imm word *) + | Psubxiw (shift : Z) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -495,6 +502,9 @@ Inductive arith_name_rri32 : Type := Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) + | Paddxil (shift : Z) + | Psubil + | Psubxil (shift : Z) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -509,6 +519,8 @@ Inductive arith_name_rri64 : Type := Inductive arith_name_arrr : Type := | Pmaddw (**r multiply add word *) | Pmaddl (**r multiply add long *) + | Pmsubw (**r multiply subtract word *) + | Pmsubl (**r multiply subtract long *) | Pcmove (bt: btest) (**r conditional move *) | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) . @@ -1055,12 +1067,33 @@ Definition arith_eval_rrr n v1 v2 := | Pfsbfw => Val.subfs v1 v2 | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 + + | Paddxw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.add v1 (Val.shl v2 (Vint (Int.repr shift))) + else Vundef + + | Paddxl shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.addl v1 (Val.shll v2 (Vint (Int.repr shift))) + else Vundef + + | Psubxw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.sub v1 (Val.shl v2 (Vint (Int.repr shift))) + else Vundef + + | Psubxl shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.subl v1 (Val.shll v2 (Vint (Int.repr shift))) + else Vundef end. Definition arith_eval_rri32 n v i := match n with | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) + | Psubiw => Val.sub v (Vint i) | Pmuliw => Val.mul v (Vint i) | Pandiw => Val.and v (Vint i) | Pnandiw => Val.notint (Val.and v (Vint i)) @@ -1079,12 +1112,21 @@ Definition arith_eval_rri32 n v i := | Psrxil => ExtValues.val_shrxl v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) + | Paddxiw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.add (Vint i) (Val.shl v (Vint (Int.repr shift))) + else Vundef + | Psubxiw shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.sub (Vint i) (Val.shl v (Vint (Int.repr shift))) + else Vundef end. Definition arith_eval_rri64 n v i := match n with | Pcompil c => compare_long c v (Vlong i) | Paddil => Val.addl v (Vlong i) + | Psubil => Val.subl v (Vlong i) | Pmulil => Val.mull v (Vlong i) | Pandil => Val.andl v (Vlong i) | Pnandil => Val.notl (Val.andl v (Vlong i)) @@ -1094,12 +1136,22 @@ Definition arith_eval_rri64 n v i := | Pnxoril => Val.notl (Val.xorl v (Vlong i)) | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) + | Paddxil shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.addl (Vlong i) (Val.shll v (Vint (Int.repr shift))) + else Vundef + | Psubxil shift => + if Z.leb shift 4 && Z.leb 1 shift + then Val.subl (Vlong i) (Val.shll v (Vint (Int.repr shift))) + else Vundef end. Definition arith_eval_arrr n v1 v2 v3 := match n with | Pmaddw => Val.add v1 (Val.mul v2 v3) | Pmaddl => Val.addl v1 (Val.mull v2 v3) + | Pmsubw => Val.sub v1 (Val.mul v2 v3) + | Pmsubl => Val.subl v1 (Val.mull v2 v3) | Pcmove bt => match cmp_for_btest bt with | (Some c, Int) => diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 39a14727..9b22cd01 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -61,7 +61,9 @@ let arith_rrr_str = function | Pfcompw ft -> "Pfcompw" | Pfcompl ft -> "Pfcompl" | Paddw -> "Paddw" + | Paddxw _ -> "Paddxw" | Psubw -> "Psubw" + | Psubxw _ -> "Psubxw" | Pmulw -> "Pmulw" | Pandw -> "Pandw" | Pnandw -> "Pnandw" @@ -76,7 +78,9 @@ let arith_rrr_str = function | Psrxw -> "Psrxw" | Psllw -> "Psllw" | Paddl -> "Paddl" + | Paddxl _ -> "Paddxl" | Psubl -> "Psubl" + | Psubxl _ -> "Psubxl" | Pandl -> "Pandl" | Pnandl -> "Pnandl" | Porl -> "Porl" @@ -100,6 +104,9 @@ let arith_rrr_str = function let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" + | Paddxiw _ -> "Paddxiw" + | Psubiw -> "Psubiw" + | Psubxiw _ -> "Psubxiw" | Pmuliw -> "Pmuliw" | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" @@ -122,6 +129,9 @@ let arith_rri32_str = function let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" + | Psubil -> "Psubil" + | Paddxil _ -> "Paddxil" + | Psubxil _ -> "Psubxil" | Pmulil -> "Pmulil" | Pandil -> "Pandil" | Pnandil -> "Pnandil" @@ -140,6 +150,8 @@ let arith_arr_str = function let arith_arrr_str = function | Pmaddw -> "Pmaddw" | Pmaddl -> "Pmaddl" + | Pmsubw -> "Pmsubw" + | Pmsubl -> "Pmsubl" | Pcmove _ -> "Pcmove" | Pcmoveu _ -> "Pcmoveu" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 114297c9..83d12da7 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -513,8 +513,18 @@ module Target (*: TARGET*) = | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxw (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Psubxw (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " subx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandw (rd, rs1, rs2) -> @@ -543,22 +553,34 @@ module Target (*: TARGET*) = fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmaddw (rd, rs1, rs2) -> fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmsubw (rd, rs1, rs2) -> + fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddl (rd, rs1, rs2) -> assert Archi.ptr64; + | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxl (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Pandl (rd, rs1, rs2) -> assert Archi.ptr64; + | Psubxl (zshift, rd, rs1, rs2) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs1 ireg rs2 + | Pandl (rd, rs1, rs2) -> fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnandl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnandl (rd, rs1, rs2) -> fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porl (rd, rs1, rs2) -> assert Archi.ptr64; + | Porl (rd, rs1, rs2) -> fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnorl (rd, rs1, rs2) -> fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pxorl (rd, rs1, rs2) -> fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnxorl (rd, rs1, rs2) -> assert Archi.ptr64; + | Pnxorl (rd, rs1, rs2) -> fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pandnl (rd, rs1, rs2) -> fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -576,6 +598,8 @@ module Target (*: TARGET*) = fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmaddl (rd, rs1, rs2) -> fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmsubl (rd, rs1, rs2) -> + fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfaddd (rd, rs1, rs2) -> fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -595,6 +619,18 @@ module Target (*: TARGET*) = fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm | Paddiw (rd, rs, imm) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Paddxiw (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint imm + | Psubiw (rd, rs, imm) -> + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psubxiw (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint imm | Pmuliw (rd, rs, imm) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm | Pandiw (rd, rs, imm) -> @@ -640,6 +676,18 @@ module Target (*: TARGET*) = fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Paddxil (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint imm + | Psubil (rd, rs, imm) -> + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psubxil (zshift, rd, rs, imm) -> + let shift = camlint_of_coqint zshift in + assert(shift >= 1l && shift <= 4l); + fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + ireg rd ireg rs coqint64 imm | Pmulil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm | Pandil (rd, rs, imm) -> assert Archi.ptr64; -- cgit From e2ea45f5ba656254fa11bf3f355da67292c11f06 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 23:37:07 +0200 Subject: more integer Op --- mppa_k1c/Machregs.v | 5 +- mppa_k1c/NeedOp.v | 60 ++++++++++++++++++++ mppa_k1c/Op.v | 159 ++++++++++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/ValueAOp.v | 38 +++++++++++-- 4 files changed, 245 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index cd8c6606..6e0efe28 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -213,7 +213,10 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with - | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ + | Omadd | Omaddimm _ + | Omaddl | Omaddlimm _ + | Omsub | Omsubimm _ + | Omsubl | Omsublimm _ | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index c10f5c56..ced31758 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -42,8 +42,13 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ocast16signed => op1 (sign_ext 16 nv) | Oadd => op2 (modarith nv) | Oaddimm n => op1 (modarith nv) + | Oaddx _ => op2 (default nv) + | Oaddximm _ _ => op1 (default nv) | Oneg => op1 (modarith nv) | Osub => op2 (default nv) + | Orevsubimm _ => op1 (default nv) + | Orevsubx _ => op2 (default nv) + | Orevsubximm _ _ => op1 (default nv) | Omul => op2 (modarith nv) | Omulimm _ => op1 (modarith nv) | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) @@ -72,12 +77,19 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshrximm n => op1 (default nv) | Omadd => op3 (modarith nv) | Omaddimm n => op2 (modarith nv) + | Omsub => op3 (modarith nv) + | Omsubimm n => op2 (modarith nv) | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocast32signed => op1 (default nv) | Ocast32unsigned => op1 (default nv) | Oaddl => op2 (default nv) | Oaddlimm n => op1 (default nv) + | Oaddxl _ => op2 (default nv) + | Oaddxlimm _ _ => op1 (default nv) + | Orevsublimm _ => op1 (default nv) + | Orevsubxl _ => op2 (default nv) + | Orevsubxlimm _ _ => op1 (default nv) | Onegl => op1 (default nv) | Osubl => op2 (default nv) | Omull => op2 (default nv) @@ -107,6 +119,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oshrxlimm n => op1 (default nv) | Omaddl => op3 (default nv) | Omaddlimm n => op2 (default nv) + | Omsubl => op3 (default nv) + | Omsublimm n => op2 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) @@ -229,6 +243,26 @@ Proof. - apply Val.addl_lessdef; trivial. Qed. +Lemma subl_lessdef: + forall v1 v1' v2 v2', + Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Val.lessdef (Val.subl v1 v2) (Val.subl v1' v2'). +Proof. + intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. +Qed. + +Lemma subl_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.subl v1 v2) (Val.subl w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.subl. + destruct v1; destruct v2; trivial; destruct Archi.ptr64; simpl; trivial. + destruct (eq_block _ _) ; simpl; trivial. + - apply subl_lessdef; trivial. +Qed. + Lemma mull_sound: forall v1 w1 v2 w2 x, @@ -424,6 +458,14 @@ Proof. destruct nv; simpl; trivial. Qed. +Remark sub_add_neg : + forall x y, Val.sub x y = Val.add x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.sub_add_opp. +Qed. + Lemma needs_of_operation_sound: forall op args v nv args', eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> @@ -466,8 +508,26 @@ Proof. (* madd *) - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. +- repeat rewrite sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. +- repeat rewrite sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. + apply vagree_same. (* maddl *) - apply addl_sound; trivial. + apply mull_sound; trivial. + rewrite default_idem; trivial. + rewrite default_idem; trivial. + (* msubl *) +- apply subl_sound; trivial. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 5e80589b..b93a9fc3 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -66,6 +66,20 @@ Definition arg_type_of_condition0 (cond: condition0) := (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) +Inductive shift1_4 : Type := +| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. + +Definition z_of_shift1_4 (x : shift1_4) := + match x with + | SHIFT1 => 1 + | SHIFT2 => 2 + | SHIFT3 => 3 + | SHIFT4 => 4 + end. + +Definition int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). + Inductive operation : Type := | Omove (**r [rd = r1] *) | Ointconst (n: int) (**r [rd] is set to the given integer constant *) @@ -79,8 +93,13 @@ Inductive operation : Type := | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) | Oadd (**r [rd = r1 + r2] *) | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oaddx (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddximm (shift: shift1_4) (n: int) (**r [rd = r1 << shift + n] *) | Oneg (**r [rd = - r1] *) | Osub (**r [rd = r1 - r2] *) + | Orevsubimm (n: int) (**r [rd = n - r1] *) + | Orevsubx (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubximm (shift: shift1_4) (n: int) (**r [rd = n -r1 << shift] *) | Omul (**r [rd = r1 * r2] *) | Omulimm (n: int) (**r [rd = r1 * n] *) | Omulhs (**r [rd = high part of r1 * r2, signed] *) @@ -116,6 +135,8 @@ Inductive operation : Type := | Ororimm (n: int) (**r rotate right immediate *) | Omadd (**r [rd = rd + r1 * r2] *) | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) + | Omsub (**r [rd = rd - r1 * r2] *) + | Omsubimm (n: int) (**r [rd = rd - r1 * imm] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -124,6 +145,11 @@ Inductive operation : Type := | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) | Oaddl (**r [rd = r1 + r2] *) | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Oaddxl (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddxlimm (shift: shift1_4) (n: int64) (**r [rd = r1 << shift + n] *) + | Orevsublimm (n: int64) (**r [rd = n - r1] *) + | Orevsubxl (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubxlimm (shift: shift1_4) (n: int64) (**r [rd = n -r1 << shift] *) | Onegl (**r [rd = - r1] *) | Osubl (**r [rd = r1 - r2] *) | Omull (**r [rd = r1 * r2] *) @@ -160,6 +186,8 @@ Inductive operation : Type := | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) | Omaddl (**r [rd = rd + r1 * r2] *) | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) + | Omsubl (**r [rd = rd - r1 * r2] *) + | Omsublimm (n: int64) (**r [rd = rd - r1 * imm] *) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -235,9 +263,14 @@ Proof. decide equality. Defined. +Definition eq_shift1_4 (x y : shift1_4): {x=y} + {x<>y}. +Proof. + decide equality. +Defined. + Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. decide equality. Defined. @@ -386,8 +419,13 @@ Definition eval_operation | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Oaddx shift, v1 :: v2 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) v2) + | Oaddximm shift n, v1 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) (Vint n)) | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) + | Orevsubx shift, v1 :: v2 :: nil => Some (Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubximm shift n, v1 :: nil => Some (Val.sub (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) @@ -423,6 +461,8 @@ Definition eval_operation | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) + | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) + | (Omsubimm n), v1::v2::nil => Some (Val.sub v1 (Val.mul v2 (Vint n))) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) @@ -431,8 +471,13 @@ Definition eval_operation | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Oaddxl shift, v1 :: v2 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) v2) + | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) (Vlong n)) | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) + | Orevsubxl shift, v1 :: v2 :: nil => Some (Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubxlimm shift n, v1 :: nil => Some (Val.subl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) | Omull, v1::v2::nil => Some (Val.mull v1 v2) | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) @@ -467,6 +512,8 @@ Definition eval_operation | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) + | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) + | (Omsublimm n), v1::v2::nil => Some (Val.subl v1 (Val.mull v2 (Vlong n))) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -583,8 +630,13 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocast16signed => (Tint :: nil, Tint) | Oadd => (Tint :: Tint :: nil, Tint) | Oaddimm _ => (Tint :: nil, Tint) + | Oaddx _ => (Tint :: Tint :: nil, Tint) + | Oaddximm _ _ => (Tint :: nil, Tint) | Oneg => (Tint :: nil, Tint) | Osub => (Tint :: Tint :: nil, Tint) + | Orevsubimm _ => (Tint :: nil, Tint) + | Orevsubx _ => (Tint :: Tint :: nil, Tint) + | Orevsubximm _ _ => (Tint :: nil, Tint) | Omul => (Tint :: Tint :: nil, Tint) | Omulimm _ => (Tint :: nil, Tint) | Omulhs => (Tint :: Tint :: nil, Tint) @@ -620,6 +672,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ororimm _ => (Tint :: nil, Tint) | Omadd => (Tint :: Tint :: Tint :: nil, Tint) | Omaddimm _ => (Tint :: Tint :: nil, Tint) + | Omsub => (Tint :: Tint :: Tint :: nil, Tint) + | Omsubimm _ => (Tint :: Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -628,6 +682,11 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ocast32unsigned => (Tint :: nil, Tlong) | Oaddl => (Tlong :: Tlong :: nil, Tlong) | Oaddlimm _ => (Tlong :: nil, Tlong) + | Oaddxl _ => (Tlong :: Tlong :: nil, Tlong) + | Oaddxlimm _ _ => (Tlong :: nil, Tlong) + | Orevsublimm _ => (Tlong :: nil, Tlong) + | Orevsubxl _ => (Tlong :: Tlong :: nil, Tlong) + | Orevsubxlimm _ _ => (Tlong :: nil, Tlong) | Onegl => (Tlong :: nil, Tlong) | Osubl => (Tlong :: Tlong :: nil, Tlong) | Omull => (Tlong :: Tlong :: nil, Tlong) @@ -664,6 +723,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oshrxlimm _ => (Tlong :: nil, Tlong) | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) + | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Omsublimm _ => (Tlong :: Tlong :: nil, Tlong) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) @@ -736,6 +797,32 @@ Proof. intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. Qed. +Remark type_sub: + forall v1 v2, Val.has_type (Val.sub v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.sub. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_subl: + forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.subl. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_shl: + forall v1 v2, Val.has_type (Val.shl v1 v2) Tint. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + +Remark type_shll: + forall v1 v2, Val.has_type (Val.shll v1 v2) Tlong. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + Lemma type_of_operation_sound: forall op vl sp v m, op <> Omove -> @@ -761,9 +848,17 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* add, addimm *) - apply type_add. - apply type_add. + (* addx, addximm *) + - apply type_add. + - apply type_add. (* neg, sub *) - destruct v0... - - unfold Val.sub. destruct v0; destruct v1... + - apply type_sub. + (* revsubimm, revsubx, revsubximm *) + - destruct v0... + - apply type_sub. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* mul, mulimm, mulhs, mulhu *) - destruct v0; destruct v1... - destruct v0... @@ -819,8 +914,11 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* shrimm *) - destruct v0; simpl... (* madd *) - - destruct v0; destruct v1; destruct v2... - - destruct v0; destruct v1... + - apply type_add. + - apply type_add. + (* msub *) + - apply type_sub. + - apply type_sub. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -831,11 +929,16 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* addl, addlimm *) - apply type_addl. - apply type_addl. + (* addxl addxlimm *) + - apply type_addl. + - apply type_addl. (* negl, subl *) - destruct v0... - - unfold Val.subl. destruct v0; destruct v1... - unfold Val.has_type; destruct Archi.ptr64... - destruct (eq_block b b0)... + - apply type_subl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - destruct v0... + - apply type_subl. (* mull, mullhs, mullhu *) - destruct v0; destruct v1... - destruct v0... @@ -889,10 +992,11 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* shrxl *) - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... (* maddl, maddlim *) - - destruct v0; destruct v1; destruct v2; simpl; trivial. - destruct Archi.ptr64; simpl; trivial. - - destruct v0; destruct v1; simpl; trivial. - destruct Archi.ptr64; simpl; trivial. + - apply type_addl. + - apply type_addl. + (* msubl, msublim *) + - apply type_subl. + - apply type_subl. (* negf, absf *) - destruct v0... - destruct v0... @@ -1359,9 +1463,19 @@ Proof. (* add, addimm *) - apply Val.add_inject; auto. - apply Val.add_inject; auto. + (* addx, addximm *) + - apply Val.add_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - apply Val.add_inject; trivial. + inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. + (* revsubimm, revsubx, revsubximm *) + - inv H4; simpl; trivial. + - apply Val.sub_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. (* mul, mulimm, mulhs, mulhu *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1424,6 +1538,11 @@ Proof. (* madd, maddim *) - inv H2; inv H3; inv H4; simpl; auto. - inv H2; inv H4; simpl; auto. + (* msub *) + - apply Val.sub_inject; auto. + inv H3; inv H2; simpl; auto. + - apply Val.sub_inject; trivial. + inv H2; inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1434,8 +1553,21 @@ Proof. (* addl, addlimm *) - apply Val.addl_inject; auto. - apply Val.addl_inject; auto. + (* addxl, addxlimm *) + - apply Val.addl_inject; auto. + inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - apply Val.addl_inject; auto. + inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - inv H4; simpl; auto. + - apply Val.subl_inject; auto. + inv H4; inv H2; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; auto. - apply Val.subl_inject; auto. (* mull, mullhs, mullhu *) - inv H4; inv H2; simpl; auto. @@ -1500,6 +1632,11 @@ Proof. inv H2; inv H3; inv H4; simpl; auto. - apply Val.addl_inject; auto. inv H4; inv H2; simpl; auto. + (* msubl, msublimm *) + - apply Val.subl_inject; auto. + inv H2; inv H3; inv H4; simpl; auto. + - apply Val.subl_inject; auto. + inv H4; inv H2; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 643cca0c..27faa33c 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -161,8 +161,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast16signed, v1 :: nil => sign_ext 16 v1 | Oadd, v1::v2::nil => add v1 v2 | Oaddimm n, v1::nil => add v1 (I n) + | Oaddx shift, v1::v2::nil => add (shl v1 (I (int_of_shift1_4 shift))) v2 + | Oaddximm shift n, v1::nil => add (shl v1 (I (int_of_shift1_4 shift))) (I n) | Oneg, v1::nil => neg v1 | Osub, v1::v2::nil => sub v1 v2 + | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift))) + | Orevsubimm n, v1::nil => sub (I n) v1 + | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift))) | Omul, v1::v2::nil => mul v1 v2 | Omulimm n, v1::nil => mul v1 (I n) | Omulhs, v1::v2::nil => mulhs v1 v2 @@ -198,6 +203,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshrximm n, v1::nil => shrx v1 (I n) | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3) | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n)) + | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3) + | Omsubimm n, v1::v2::nil => sub v1 (mul v2 (I n)) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 @@ -205,8 +212,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast32unsigned, v1::nil => longofintu v1 | Oaddl, v1::v2::nil => addl v1 v2 | Oaddlimm n, v1::nil => addl v1 (L n) + | Oaddxl shift, v1::v2::nil => addl (shll v1 (I (int_of_shift1_4 shift))) v2 + | Oaddxlimm shift n, v1::nil => addl (shll v1 (I (int_of_shift1_4 shift))) (L n) | Onegl, v1::nil => negl v1 | Osubl, v1::v2::nil => subl v1 v2 + | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Orevsublimm n, v1::nil => subl (L n) v1 + | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift))) | Omull, v1::v2::nil => mull v1 v2 | Omullimm n, v1::nil => mull v1 (L n) | Omullhs, v1::v2::nil => mullhs v1 v2 @@ -241,6 +253,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Oshrxlimm n, v1::nil => shrxl v1 (I n) | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3) | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n)) + | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3) + | Omsublimm n, v1::v2::nil => subl v1 (mull v2 (L n)) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 @@ -360,11 +374,25 @@ Theorem eval_static_operation_sound: vmatch bc vres (eval_static_operation op aargs). Proof. unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros; - destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - rewrite Ptrofs.add_zero_l; eauto with va. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + destruct op; try (InvHyps; eauto with va). + - destruct (propagate_float_constants tt); constructor. + - destruct (propagate_float_constants tt); constructor. + - rewrite Ptrofs.add_zero_l; eauto with va. + - (*revsubimm*) inv H1; constructor. + - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.sub n n2) + | _ => Vundef + end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. + - inv H1; constructor. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.sub n n2) + | _ => Vundef + end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. + - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. (* select *) - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). rewrite eval_select_to2. -- cgit From 295058286407ec6c4182f2b12b27608fc7d28f95 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 May 2019 23:53:02 +0200 Subject: use shift 1-4 in backend --- mppa_k1c/Asm.v | 16 ++++++------- mppa_k1c/Asmvliw.v | 61 ++++++++++++++--------------------------------- mppa_k1c/ExtValues.v | 14 +++++++++++ mppa_k1c/Op.v | 14 ----------- mppa_k1c/TargetPrinter.ml | 54 +++++++++++++++++------------------------ 5 files changed, 62 insertions(+), 97 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 6a4095da..04f6969b 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -182,9 +182,9 @@ Inductive instruction : Type := | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Psubxw (shift : Z) (rd rs1 rs2: ireg) (**r add word *) + | Psubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) | Pmulw (rd rs1 rs2: ireg) (**r mul word *) | Pandw (rd rs1 rs2: ireg) (**r and word *) | Pnandw (rd rs1 rs2: ireg) (**r nand word *) @@ -202,9 +202,9 @@ Inductive instruction : Type := | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : Z) (rd rs1 rs2: ireg) (**r add long shift *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Psubxl (shift : Z) (rd rs1 rs2: ireg) (**r sub long shift *) + | Psubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) | Pandl (rd rs1 rs2: ireg) (**r and long *) | Pnandl (rd rs1 rs2: ireg) (**r nand long *) | Porl (rd rs1 rs2: ireg) (**r or long *) @@ -232,9 +232,9 @@ Inductive instruction : Type := | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : Z) (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Psubxiw (shift : Z) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Psubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) @@ -258,9 +258,9 @@ Inductive instruction : Type := (** Arith RRI64 *) | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : Z) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Psubxil (shift : Z) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Psubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e8ea4318..e332cedc 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -429,9 +429,9 @@ Inductive arith_name_rrr : Type := | Pfcompl (ft: ftest) (**r comparison float64 *) | Paddw (**r add word *) - | Paddxw (shift : Z) (**r add shift *) + | Paddxw (shift : shift1_4) (**r add shift *) | Psubw (**r sub word word *) - | Psubxw (shift : Z) (**r sub shift word *) + | Psubxw (shift : shift1_4) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -447,9 +447,9 @@ Inductive arith_name_rrr : Type := | Psllw (**r shift left logical word *) | Paddl (**r add long *) - | Paddxl (shift : Z) (**r add shift long *) + | Paddxl (shift : shift1_4) (**r add shift long *) | Psubl (**r sub long *) - | Psubxl (shift : Z) (**r sub shift long *) + | Psubxl (shift : shift1_4) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -476,9 +476,9 @@ Inductive arith_name_rri32 : Type := | Pcompiw (it: itest) (**r comparison imm word *) | Paddiw (**r add imm word *) - | Paddxiw (shift : Z) + | Paddxiw (shift : shift1_4) | Psubiw (**r add imm word *) - | Psubxiw (shift : Z) + | Psubxiw (shift : shift1_4) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -502,9 +502,9 @@ Inductive arith_name_rri32 : Type := Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) - | Paddxil (shift : Z) + | Paddxil (shift : shift1_4) | Psubil - | Psubxil (shift : Z) + | Psubxil (shift : shift1_4) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -1068,25 +1068,12 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.add v1 (Val.shl v2 (Vint (Int.repr shift))) - else Vundef - - | Paddxl shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.addl v1 (Val.shll v2 (Vint (Int.repr shift))) - else Vundef - - | Psubxw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.sub v1 (Val.shl v2 (Vint (Int.repr shift))) - else Vundef - - | Psubxl shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.subl v1 (Val.shll v2 (Vint (Int.repr shift))) - else Vundef + | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + + | Psubxw shift => Val.sub v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + + | Psubxl shift => Val.subl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri32 n v i := @@ -1112,14 +1099,8 @@ Definition arith_eval_rri32 n v i := | Psrxil => ExtValues.val_shrxl v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) - | Paddxiw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.add (Vint i) (Val.shl v (Vint (Int.repr shift))) - else Vundef - | Psubxiw shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.sub (Vint i) (Val.shl v (Vint (Int.repr shift))) - else Vundef + | Paddxiw shift => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Psubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri64 n v i := @@ -1136,14 +1117,8 @@ Definition arith_eval_rri64 n v i := | Pnxoril => Val.notl (Val.xorl v (Vlong i)) | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) - | Paddxil shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.addl (Vlong i) (Val.shll v (Vint (Int.repr shift))) - else Vundef - | Psubxil shift => - if Z.leb shift 4 && Z.leb 1 shift - then Val.subl (Vlong i) (Val.shll v (Vint (Int.repr shift))) - else Vundef + | Paddxil shift => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | Psubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 5d16b79c..1aa17458 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -2,6 +2,20 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Inductive shift1_4 : Type := +| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. + +Definition z_of_shift1_4 (x : shift1_4) := + match x with + | SHIFT1 => 1 + | SHIFT2 => 2 + | SHIFT3 => 3 + | SHIFT4 => 4 + end. + +Definition int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). + Definition is_bitfield stop start := (Z.leb start stop) && (Z.geb start Z.zero) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index b93a9fc3..4abd104e 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -66,20 +66,6 @@ Definition arg_type_of_condition0 (cond: condition0) := (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) -Inductive shift1_4 : Type := -| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. - -Definition z_of_shift1_4 (x : shift1_4) := - match x with - | SHIFT1 => 1 - | SHIFT2 => 2 - | SHIFT3 => 3 - | SHIFT4 => 4 - end. - -Definition int_of_shift1_4 (x : shift1_4) := - Int.repr (z_of_shift1_4 x). - Inductive operation : Type := | Omove (**r [rd = r1] *) | Ointconst (n: int) (**r [rd] is set to the given integer constant *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 83d12da7..6a21e63d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -130,6 +130,12 @@ module Target (*: TARGET*) = | RA -> "$ra" | _ -> assert false + let scale_of_shift1_4 = let open ExtValues in function + | SHIFT1 -> 2 + | SHIFT2 -> 4 + | SHIFT3 -> 8 + | SHIFT4 -> 16;; + (* Names of sections *) let name_of_section = function @@ -513,17 +519,13 @@ module Target (*: TARGET*) = | Paddw (rd, rs1, rs2) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxw (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxw (s14, rd, rs1, rs2) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxw (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " subx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxw (s14, rd, rs1, rs2) -> + fprintf oc " subx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -558,17 +560,13 @@ module Target (*: TARGET*) = | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxl (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxl (s14, rd, rs1, rs2) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxl (zshift, rd, rs1, rs2) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxl (s14, rd, rs1, rs2) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pandl (rd, rs1, rs2) -> fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -619,17 +617,13 @@ module Target (*: TARGET*) = fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm | Paddiw (rd, rs, imm) -> fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Paddxiw (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxiw (s14, rd, rs, imm) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Psubiw (rd, rs, imm) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psubxiw (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dw %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxiw (s14, rd, rs, imm) -> + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Pmuliw (rd, rs, imm) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm @@ -676,17 +670,13 @@ module Target (*: TARGET*) = fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm | Paddil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Paddxil (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " addx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Paddxil (s14, rd, rs, imm) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Psubil (rd, rs, imm) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psubxil (zshift, rd, rs, imm) -> - let shift = camlint_of_coqint zshift in - assert(shift >= 1l && shift <= 4l); - fprintf oc " sbfx%dd %a = %a, %a\n" (1 lsl (Int32.to_int shift)) + | Psubxil (s14, rd, rs, imm) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint64 imm | Pmulil (rd, rs, imm) -> assert Archi.ptr64; fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm -- cgit From d8d22519bff9414f973a1310cb32eb60e6695796 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:02:13 +0200 Subject: begin generating Prevsub etc. from Oxxx to Pxxx --- mppa_k1c/Asm.v | 24 ++++++++++++------------ mppa_k1c/Asmblockdeps.v | 12 ++++++------ mppa_k1c/Asmblockgen.v | 3 +++ mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmvliw.v | 24 ++++++++++++------------ mppa_k1c/PostpassSchedulingOracle.ml | 12 ++++++------ mppa_k1c/TargetPrinter.ml | 12 ++++++------ 7 files changed, 46 insertions(+), 43 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 04f6969b..e5f81fbb 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -184,7 +184,7 @@ Inductive instruction : Type := | Paddw (rd rs1 rs2: ireg) (**r add word *) | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Psubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) | Pmulw (rd rs1 rs2: ireg) (**r mul word *) | Pandw (rd rs1 rs2: ireg) (**r and word *) | Pnandw (rd rs1 rs2: ireg) (**r nand word *) @@ -204,7 +204,7 @@ Inductive instruction : Type := | Paddl (rd rs1 rs2: ireg) (**r add long *) | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Psubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) | Pandl (rd rs1 rs2: ireg) (**r and long *) | Pnandl (rd rs1 rs2: ireg) (**r nand long *) | Porl (rd rs1 rs2: ireg) (**r or long *) @@ -233,8 +233,8 @@ Inductive instruction : Type := | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Psubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Psubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) @@ -259,8 +259,8 @@ Inductive instruction : Type := | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Psubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Psubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) @@ -352,7 +352,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Psubxw shift) rd rs1 rs2 => Psubxw shift rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 @@ -370,7 +370,7 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Psubxl shift) rd rs1 rs2 => Psubxl shift rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 @@ -396,8 +396,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Psubiw rd rs imm => Psubiw rd rs imm - | PArithRRI32 (Asmvliw.Psubxiw shift) rd rs imm => Psubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm @@ -421,8 +421,8 @@ Definition basic_to_instruction (b: basic) := | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Psubil rd rs imm => Psubil rd rs imm - | PArithRRI64 (Asmvliw.Psubxil shift) rd rs imm => Psubxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 82062fab..616ec6db 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1412,7 +1412,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Paddw => "Paddw" | Paddxw _ => "Paddxw" | Psubw => "Psubw" - | Psubxw _ => "Psubxw" + | Prevsubxw _ => "Prevsubxw" | Pmulw => "Pmulw" | Pandw => "Pandw" | Pnandw => "Pnandw" @@ -1429,7 +1429,7 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Paddl => "Paddl" | Paddxl _ => "Paddxl" | Psubl => "Psubl" - | Psubxl _ => "Psubxl" + | Prevsubxl _ => "Prevsubxl" | Pandl => "Pandl" | Pnandl => "Pnandl" | Porl => "Porl" @@ -1455,9 +1455,9 @@ Definition string_of_name_rri32 (n: arith_name_rri32): pstring := match n with Pcompiw _ => "Pcompiw" | Paddiw => "Paddiw" - | Psubiw => "Psubiw" | Paddxiw _ => "Paddxiw" - | Psubxiw _ => "Psubxiw" + | Prevsubiw => "Prevsubiw" + | Prevsubxiw _ => "Prevsubxiw" | Pmuliw => "Pmuliw" | Pandiw => "Pandiw" | Pnandiw => "Pnandiw" @@ -1482,9 +1482,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring := match n with Pcompil _ => "Pcompil" | Paddil => "Paddil" - | Psubil => "Psubil" + | Prevsubil => "Prevsubil" | Paddxil _ => "Paddxil" - | Psubxil _ => "Psubxil" + | Prevsubxil _ => "Prevsubxil" | Pmulil => "Pmulil" | Pandil => "Pandil" | Pnandil => "Pnandil" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index f2292f9a..839d444d 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -449,6 +449,9 @@ Definition transl_op | Osub, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubw rd rs1 rs2 ::i k) + | Orevsubimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubiw rd rs n ::i k) | Omul, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulw rd rs1 rs2 ::i k) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 86a0ff88..1569aedf 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1693,7 +1693,7 @@ Opaque Int.eq. split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e332cedc..2bf9115e 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -431,7 +431,7 @@ Inductive arith_name_rrr : Type := | Paddw (**r add word *) | Paddxw (shift : shift1_4) (**r add shift *) | Psubw (**r sub word word *) - | Psubxw (shift : shift1_4) (**r sub shift word *) + | Prevsubxw (shift : shift1_4) (**r sub shift word *) | Pmulw (**r mul word *) | Pandw (**r and word *) | Pnandw (**r nand word *) @@ -449,7 +449,7 @@ Inductive arith_name_rrr : Type := | Paddl (**r add long *) | Paddxl (shift : shift1_4) (**r add shift long *) | Psubl (**r sub long *) - | Psubxl (shift : shift1_4) (**r sub shift long *) + | Prevsubxl (shift : shift1_4) (**r sub shift long *) | Pandl (**r and long *) | Pnandl (**r nand long *) | Porl (**r or long *) @@ -477,8 +477,8 @@ Inductive arith_name_rri32 : Type := | Paddiw (**r add imm word *) | Paddxiw (shift : shift1_4) - | Psubiw (**r add imm word *) - | Psubxiw (shift : shift1_4) + | Prevsubiw (**r add imm word *) + | Prevsubxiw (shift : shift1_4) | Pmuliw (**r add imm word *) | Pandiw (**r and imm word *) | Pnandiw (**r nand imm word *) @@ -503,8 +503,8 @@ Inductive arith_name_rri64 : Type := | Pcompil (it: itest) (**r comparison imm long *) | Paddil (**r add immediate long *) | Paddxil (shift : shift1_4) - | Psubil - | Psubxil (shift : shift1_4) + | Prevsubil + | Prevsubxil (shift : shift1_4) | Pmulil (**r mul immediate long *) | Pandil (**r and immediate long *) | Pnandil (**r nand immediate long *) @@ -1071,16 +1071,16 @@ Definition arith_eval_rrr n v1 v2 := | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) - | Psubxw shift => Val.sub v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) + | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) - | Psubxl shift => Val.subl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + | Prevsubxl shift => Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri32 n v i := match n with | Pcompiw c => compare_int c v (Vint i) | Paddiw => Val.add v (Vint i) - | Psubiw => Val.sub v (Vint i) + | Prevsubiw => Val.sub (Vint i) v | Pmuliw => Val.mul v (Vint i) | Pandiw => Val.and v (Vint i) | Pnandiw => Val.notint (Val.and v (Vint i)) @@ -1100,14 +1100,14 @@ Definition arith_eval_rri32 n v i := | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) | Paddxiw shift => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) - | Psubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Prevsubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_rri64 n v i := match n with | Pcompil c => compare_long c v (Vlong i) | Paddil => Val.addl v (Vlong i) - | Psubil => Val.subl v (Vlong i) + | Prevsubil => Val.subl (Vlong i) v | Pmulil => Val.mull v (Vlong i) | Pandil => Val.andl v (Vlong i) | Pnandil => Val.notl (Val.andl v (Vlong i)) @@ -1118,7 +1118,7 @@ Definition arith_eval_rri64 n v i := | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) | Paddxil shift => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) - | Psubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | Prevsubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) end. Definition arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9b22cd01..9dc1ab44 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -63,7 +63,7 @@ let arith_rrr_str = function | Paddw -> "Paddw" | Paddxw _ -> "Paddxw" | Psubw -> "Psubw" - | Psubxw _ -> "Psubxw" + | Prevsubxw _ -> "Psubxw" | Pmulw -> "Pmulw" | Pandw -> "Pandw" | Pnandw -> "Pnandw" @@ -80,7 +80,7 @@ let arith_rrr_str = function | Paddl -> "Paddl" | Paddxl _ -> "Paddxl" | Psubl -> "Psubl" - | Psubxl _ -> "Psubxl" + | Prevsubxl _ -> "Psubxl" | Pandl -> "Pandl" | Pnandl -> "Pnandl" | Porl -> "Porl" @@ -105,8 +105,8 @@ let arith_rri32_str = function | Pcompiw it -> "Pcompiw" | Paddiw -> "Paddiw" | Paddxiw _ -> "Paddxiw" - | Psubiw -> "Psubiw" - | Psubxiw _ -> "Psubxiw" + | Prevsubiw -> "Psubiw" + | Prevsubxiw _ -> "Psubxiw" | Pmuliw -> "Pmuliw" | Pandiw -> "Pandiw" | Pnandiw -> "Pnandiw" @@ -129,9 +129,9 @@ let arith_rri32_str = function let arith_rri64_str = function | Pcompil it -> "Pcompil" | Paddil -> "Paddil" - | Psubil -> "Psubil" + | Prevsubil -> "Psubil" | Paddxil _ -> "Paddxil" - | Psubxil _ -> "Psubxil" + | Prevsubxil _ -> "Psubxil" | Pmulil -> "Pmulil" | Pandil -> "Pandil" | Pnandil -> "Pnandil" diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 6a21e63d..2d870c01 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -524,7 +524,7 @@ module Target (*: TARGET*) = ireg rd ireg rs1 ireg rs2 | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxw (s14, rd, rs1, rs2) -> + | Prevsubxw (s14, rd, rs1, rs2) -> fprintf oc " subx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> @@ -565,7 +565,7 @@ module Target (*: TARGET*) = ireg rd ireg rs1 ireg rs2 | Psubl (rd, rs1, rs2) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Psubxl (s14, rd, rs1, rs2) -> + | Prevsubxl (s14, rd, rs1, rs2) -> fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pandl (rd, rs1, rs2) -> @@ -620,9 +620,9 @@ module Target (*: TARGET*) = | Paddxiw (s14, rd, rs, imm) -> fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm - | Psubiw (rd, rs, imm) -> + | Prevsubiw (rd, rs, imm) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psubxiw (s14, rd, rs, imm) -> + | Prevsubxiw (s14, rd, rs, imm) -> fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm | Pmuliw (rd, rs, imm) -> @@ -673,9 +673,9 @@ module Target (*: TARGET*) = | Paddxil (s14, rd, rs, imm) -> fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint imm - | Psubil (rd, rs, imm) -> + | Prevsubil (rd, rs, imm) -> fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psubxil (s14, rd, rs, imm) -> + | Prevsubxil (s14, rd, rs, imm) -> fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs coqint64 imm | Pmulil (rd, rs, imm) -> assert Archi.ptr64; -- cgit From d336d31434602b786bcaa89c8d91d2472d9cb3f5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:35:31 +0200 Subject: Oaddx -> P --- mppa_k1c/Asmblockgen.v | 6 ++++++ mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmvliw.v | 4 ++-- mppa_k1c/Op.v | 20 ++++++++++---------- mppa_k1c/ValueAOp.v | 37 +++++++++++++++++++++++++++++-------- 5 files changed, 48 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 839d444d..ef980894 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -443,6 +443,12 @@ Definition transl_op | Oaddimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (addimm32 rd rs n ::i k) + | Oaddx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxw shift rd rs1 rs2 ::i k) + | Oaddximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxiw shift rd rs n ::i k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs ::i k) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1569aedf..86a0ff88 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1693,7 +1693,7 @@ Opaque Int.eq. split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 2bf9115e..c1f21f8d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1068,8 +1068,8 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => Val.add v1 (Val.shl v2 (Vint (int_of_shift1_4 shift))) - | Paddxl shift => Val.addl v1 (Val.shll v2 (Vint (int_of_shift1_4 shift))) + | Paddxw shift => Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4abd104e..fb6c454c 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -405,8 +405,8 @@ Definition eval_operation | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) - | Oaddx shift, v1 :: v2 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) v2) - | Oaddximm shift n, v1 :: nil => Some (Val.add (Val.shl v1 (Vint (int_of_shift1_4 shift))) (Vint n)) + | Oaddx shift, v1 :: v2 :: nil => Some (Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Oaddximm shift n, v1 :: nil => Some (Val.add (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) @@ -457,8 +457,8 @@ Definition eval_operation | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) - | Oaddxl shift, v1 :: v2 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) v2) - | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Val.shll v1 (Vint (int_of_shift1_4 shift))) (Vlong n)) + | Oaddxl shift, v1 :: v2 :: nil => Some (Val.addl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) @@ -836,7 +836,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_add. (* addx, addximm *) - apply type_add. - - apply type_add. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* neg, sub *) - destruct v0... - apply type_sub. @@ -917,7 +918,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_addl. (* addxl addxlimm *) - apply type_addl. - - apply type_addl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - destruct v0... - apply type_subl. @@ -1452,8 +1454,7 @@ Proof. (* addx, addximm *) - apply Val.add_inject; trivial. inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - apply Val.add_inject; trivial. - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; trivial. try destruct (Int.ltu _ _); simpl; auto. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. @@ -1543,8 +1544,7 @@ Proof. - apply Val.addl_inject; auto. inv H4; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. - - apply Val.addl_inject; auto. - inv H4; simpl; trivial. + - inv H4; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. (* negl, subl *) - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 27faa33c..00e8a1d8 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -161,8 +161,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast16signed, v1 :: nil => sign_ext 16 v1 | Oadd, v1::v2::nil => add v1 v2 | Oaddimm n, v1::nil => add v1 (I n) - | Oaddx shift, v1::v2::nil => add (shl v1 (I (int_of_shift1_4 shift))) v2 - | Oaddximm shift n, v1::nil => add (shl v1 (I (int_of_shift1_4 shift))) (I n) + | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift))) + | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift))) | Oneg, v1::nil => neg v1 | Osub, v1::v2::nil => sub v1 v2 | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift))) @@ -212,8 +212,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ocast32unsigned, v1::nil => longofintu v1 | Oaddl, v1::v2::nil => addl v1 v2 | Oaddlimm n, v1::nil => addl v1 (L n) - | Oaddxl shift, v1::v2::nil => addl (shll v1 (I (int_of_shift1_4 shift))) v2 - | Oaddxlimm shift n, v1::nil => addl (shll v1 (I (int_of_shift1_4 shift))) (L n) + | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift))) | Onegl, v1::nil => negl v1 | Osubl, v1::v2::nil => subl v1 v2 | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift))) @@ -378,20 +378,41 @@ Proof. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - rewrite Ptrofs.add_zero_l; eauto with va. + - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vundef + else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n)) + | _ => Vundef + end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. - (*revsubimm*) inv H1; constructor. - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with | Vint n2 => Vint (Int.sub n n2) | _ => Vundef end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). - eauto with va. - destruct a1; destruct shift; reflexivity. + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) + else Vundef + | _ => Vundef + end) with + (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. - inv H1; constructor. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.sub n n2) | _ => Vundef end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). - eauto with va. - destruct a1; destruct shift; reflexivity. + + eauto with va. + + destruct a1; destruct shift; reflexivity. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. (* select *) - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). -- cgit From f3d9c333fb27b1afb733b7aa8dfc9e2b22b596aa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:41:20 +0200 Subject: more gen O -> P --- mppa_k1c/Asmblockgen.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ef980894..505d6c86 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -458,6 +458,12 @@ Definition transl_op | Orevsubimm n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Prevsubiw rd rs n ::i k) + | Orevsubx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxw shift rd rs1 rs2 ::i k) + | Orevsubximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxiw shift rd rs n ::i k) | Omul, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmulw rd rs1 rs2 ::i k) -- cgit From 428af5f71a063962e53e4ab58eaa372ccc926394 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 06:47:39 +0200 Subject: more gen O -> P --- mppa_k1c/Asmblockgen.v | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 505d6c86..4cce7075 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -582,6 +582,15 @@ Definition transl_op | Osubl, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Psubl rd rs1 rs2 ::i k) + | Orevsubxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxl shift rd rs1 rs2 ::i k) + | Orevsublimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubil rd rs n ::i k) + | Orevsubxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxil shift rd rs n ::i k) | Omull, a1 :: a2 :: nil => do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; OK (Pmull rd rs1 rs2 ::i k) -- cgit From ae22df3c5ef0a60527ea85b83bb71e8c95a6ab9c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 07:59:11 +0200 Subject: Pmsub compiled --- mppa_k1c/Asmblockgen.v | 12 ++++++++++++ mppa_k1c/ExtValues.v | 16 ++++++++++++++++ mppa_k1c/Machregs.v | 3 +-- mppa_k1c/NeedOp.v | 19 +------------------ mppa_k1c/Op.v | 14 +------------- mppa_k1c/PostpassSchedulingOracle.ml | 12 +++++++----- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 6 ++++++ mppa_k1c/ValueAOp.v | 2 -- 9 files changed, 48 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 4cce7075..7be83962 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -558,6 +558,12 @@ Definition transl_op do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pmaddiw r1 r2 n ::i k) + | Omsub, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubw r1 r2 r3 ::i k) (* [Omakelong], [Ohighlong] should not occur *) | Olowlong, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; @@ -686,6 +692,12 @@ Definition transl_op do r1 <- ireg_of a1; do r2 <- ireg_of a2; OK (Pmaddil r1 r2 n ::i k) + | Omsubl, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubl r1 r2 r3 ::i k) | Oabsf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfabsd rd rs ::i k) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 1aa17458..0d56fd1c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -131,3 +131,19 @@ Definition val_shrxl (v1 v2: val): val := else Vundef | _, _ => Vundef end. + +Lemma sub_add_neg : + forall x y, Val.sub x y = Val.add x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.sub_add_opp. +Qed. + +Lemma neg_mul_distr_r : + forall x y, Val.neg (Val.mul x y) = Val.mul x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.neg_mul_distr_r. +Qed. \ No newline at end of file diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 6e0efe28..db3dfe64 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -215,8 +215,7 @@ Definition two_address_op (op: operation) : bool := match op with | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ - | Omsub | Omsubimm _ - | Omsubl | Omsublimm _ + | Omsub | Omsubl | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index ced31758..5ba9851f 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -78,7 +78,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omadd => op3 (modarith nv) | Omaddimm n => op2 (modarith nv) | Omsub => op3 (modarith nv) - | Omsubimm n => op2 (modarith nv) | Omakelong => op2 (default nv) | Olowlong | Ohighlong => op1 (default nv) | Ocast32signed => op1 (default nv) @@ -120,7 +119,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omaddl => op3 (default nv) | Omaddlimm n => op2 (default nv) | Omsubl => op3 (default nv) - | Omsublimm n => op2 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) @@ -457,14 +455,6 @@ Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. Qed. - -Remark sub_add_neg : - forall x y, Val.sub x y = Val.add x (Val.neg y). -Proof. - destruct x; destruct y; simpl; trivial. - f_equal. - apply Int.sub_add_opp. -Qed. Lemma needs_of_operation_sound: forall op args v nv args', @@ -508,19 +498,12 @@ Proof. (* madd *) - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. - apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. -- repeat rewrite sub_add_neg. - apply add_sound; trivial. - apply neg_sound; trivial. - rewrite modarith_idem. - apply mul_sound; - rewrite modarith_idem; trivial. -- repeat rewrite sub_add_neg. +- repeat rewrite ExtValues.sub_add_neg. apply add_sound; trivial. apply neg_sound; trivial. rewrite modarith_idem. apply mul_sound; rewrite modarith_idem; trivial. - apply vagree_same. (* maddl *) - apply addl_sound; trivial. apply mull_sound; trivial. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index fb6c454c..ac40c293 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -122,7 +122,6 @@ Inductive operation : Type := | Omadd (**r [rd = rd + r1 * r2] *) | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) | Omsub (**r [rd = rd - r1 * r2] *) - | Omsubimm (n: int) (**r [rd = rd - r1 * imm] *) (*c 64-bit integer arithmetic: *) | Omakelong (**r [rd = r1 << 32 | r2] *) | Olowlong (**r [rd = low-word(r1)] *) @@ -173,7 +172,6 @@ Inductive operation : Type := | Omaddl (**r [rd = rd + r1 * r2] *) | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) | Omsubl (**r [rd = rd - r1 * r2] *) - | Omsublimm (n: int64) (**r [rd = rd - r1 * imm] *) (*c Floating-point arithmetic: *) | Onegf (**r [rd = - r1] *) | Oabsf (**r [rd = abs(r1)] *) @@ -448,7 +446,6 @@ Definition eval_operation | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) - | (Omsubimm n), v1::v2::nil => Some (Val.sub v1 (Val.mul v2 (Vint n))) | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) | Olowlong, v1::nil => Some (Val.loword v1) @@ -499,7 +496,6 @@ Definition eval_operation | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) - | (Omsublimm n), v1::v2::nil => Some (Val.subl v1 (Val.mull v2 (Vlong n))) | Onegf, v1::nil => Some (Val.negf v1) | Oabsf, v1::nil => Some (Val.absf v1) @@ -659,7 +655,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omadd => (Tint :: Tint :: Tint :: nil, Tint) | Omaddimm _ => (Tint :: Tint :: nil, Tint) | Omsub => (Tint :: Tint :: Tint :: nil, Tint) - | Omsubimm _ => (Tint :: Tint :: nil, Tint) | Omakelong => (Tint :: Tint :: nil, Tlong) | Olowlong => (Tlong :: nil, Tint) @@ -710,7 +705,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) - | Omsublimm _ => (Tlong :: Tlong :: nil, Tlong) | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) @@ -905,7 +899,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - apply type_add. (* msub *) - apply type_sub. - - apply type_sub. (* makelong, lowlong, highlong *) - destruct v0; destruct v1... - destruct v0... @@ -982,8 +975,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* maddl, maddlim *) - apply type_addl. - apply type_addl. - (* msubl, msublim *) - - apply type_subl. + (* msubl *) - apply type_subl. (* negf, absf *) - destruct v0... @@ -1528,8 +1520,6 @@ Proof. (* msub *) - apply Val.sub_inject; auto. inv H3; inv H2; simpl; auto. - - apply Val.sub_inject; trivial. - inv H2; inv H4; simpl; auto. (* makelong, highlong, lowlong *) - inv H4; inv H2; simpl; auto. - inv H4; simpl; auto. @@ -1621,8 +1611,6 @@ Proof. (* msubl, msublimm *) - apply Val.subl_inject; auto. inv H2; inv H3; inv H4; simpl; auto. - - apply Val.subl_inject; auto. - inv H4; inv H2; simpl; auto. (* negf, absf *) - inv H4; simpl; auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9dc1ab44..f428fe49 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -464,7 +464,7 @@ type real_instruction = | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Srsd | Xord | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd - | Maddw | Maddd | Cmoved + | Maddw | Maddd | Msbfw | Msbfd | Cmoved | Make | Nop | Extfz | Extfs | Insf (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo @@ -505,6 +505,7 @@ let ab_inst_to_real = function | "Psllw" | "Pslliw" -> Sllw | "Proriw" -> Rorw | "Pmaddw" | "Pmaddiw" -> Maddw + | "Pmsubw" | "Pmsubiw" -> Msbfw | "Pslll" | "Psllil" -> Slld | "Pxorw" | "Pxoriw" -> Xorw | "Pnxorw" | "Pnxoriw" -> Nxorw @@ -514,7 +515,8 @@ let ab_inst_to_real = function | "Pnxorl" | "Pnxoril" -> Nxord | "Pandnl" | "Pandnil" -> Andnd | "Pornl" | "Pornil" -> Ornd - | "Pmaddl" -> Maddd + | "Pmaddl" | "Pmaddil" -> Maddd + | "Pmsubl" | "Pmsubil" -> Msbfd | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make | "Pnop" | "Pcvtw2l" -> Nop | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz @@ -608,10 +610,10 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw| Maddw -> (match encoding with None -> mau + | Mulw| Maddw | Msbfw -> (match encoding with None -> mau | Some U6 | Some S10 | Some U27L5 -> mau_x | _ -> raise InvalidEncoding) - | Muld | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau + | Muld | Maddd | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop @@ -644,7 +646,7 @@ let real_inst_to_latency = function | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 - | Mulw | Muld | Maddw | Maddd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) + | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> 3 | Sb | Sh | Sw | Sd | Sq | So -> 1 (* See k1c-Optimization.pdf page 19 *) | Get -> 1 diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6adcebe5..81e288cb 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -151,6 +151,10 @@ Nondetfunction sub (e1: expr) (e2: expr) := addimm n1 (Eop Osub (t1:::t2:::Enil)) | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + Eop Omsub (t1:::t2:::t3:::Enil) + | t1, (Eop (Omulimm n) (t2:::Enil)) => + Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) | _, _ => Eop Osub (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 9e2eec8b..17024826 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -251,6 +251,12 @@ Proof. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + - TrivialExists. simpl. subst. reflexivity. + - TrivialExists. simpl. subst. + rewrite sub_add_neg. + rewrite neg_mul_distr_r. + unfold Val.neg. + reflexivity. - TrivialExists. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 00e8a1d8..adc27010 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -204,7 +204,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3) | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n)) | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3) - | Omsubimm n, v1::v2::nil => sub v1 (mul v2 (I n)) | Omakelong, v1::v2::nil => longofwords v1 v2 | Olowlong, v1::nil => loword v1 | Ohighlong, v1::nil => hiword v1 @@ -254,7 +253,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3) | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n)) | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3) - | Omsublimm n, v1::v2::nil => subl v1 (mull v2 (L n)) | Onegf, v1::nil => negf v1 | Oabsf, v1::nil => absf v1 | Oaddf, v1::v2::nil => addf v1 v2 -- cgit From 3ef3e6c78026cc1d5793ccb4e905a0232ec7bb4e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 10:21:59 +0200 Subject: generate multiply-sub long --- mppa_k1c/ExtValues.v | 33 ++++++++++++++++++++++++++++++++- mppa_k1c/SelectLong.vp | 6 +++++- mppa_k1c/SelectLongproof.v | 21 +++++++++++++++++++-- 3 files changed, 56 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 0d56fd1c..735d5c3c 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -146,4 +146,35 @@ Proof. destruct x; destruct y; simpl; trivial. f_equal. apply Int.neg_mul_distr_r. -Qed. \ No newline at end of file +Qed. + +(* pointer diff +Lemma sub_addl_negl : + forall x y, Val.subl x y = Val.addl x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + + f_equal. apply Int64.sub_add_opp. + + destruct (Archi.ptr64) eqn:ARCHI64; trivial. + f_equal. rewrite Ptrofs.sub_add_opp. + pose (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 i0) i0) as Hagree. + unfold Ptrofs.agree64 in Hagree. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite Hagree. + pose (Ptrofs.agree64_of_int ARCHI64 (Int64.neg i0)) as Hagree2. + rewrite Hagree2. + reflexivity. + exact (Ptrofs.agree64_of_int ARCHI64 i0). + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + destruct (eq_block _ _); simpl; trivial. +Qed. + *) + +Lemma negl_mull_distr_r : + forall x y, Val.negl (Val.mull x y) = Val.mull x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int64.neg_mul_distr_r. +Qed. + diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 717b0120..b29b9712 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -118,6 +118,10 @@ Nondetfunction subl (e1: expr) (e2: expr) := addlimm n1 (Eop Osubl (t1:::t2:::Enil)) | t1, Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | t1, (Eop Omull (t2:::t3:::Enil)) => + Eop Omsubl (t1:::t2:::t3:::Enil) + | t1, (Eop (Omullimm n) (t2:::Enil)) => + Eop (Omaddlimm (Int64.neg n)) (t1:::t2:::Enil) | _, _ => Eop Osubl (e1:::e2:::Enil) end. @@ -225,7 +229,7 @@ Definition mullimm_base (n1: int64) (e2: expr) := | i :: j :: nil => Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) | _ => - Eop Omull (e2 ::: longconst n1 ::: Enil) + Eop (Omullimm n1) (e2 ::: Enil) end. Nondetfunction mullimm (n1: int64) (e2: expr) := diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3b724c01..257c7fd9 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -208,6 +208,23 @@ Proof. - subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. - subst. rewrite Val.subl_addl_r. apply eval_addlimm; EvalOp. +- TrivialExists. simpl. subst. reflexivity. +- TrivialExists. simpl. subst. + destruct v1; destruct x; simpl; trivial. + + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Int64.sub_add_opp. + reflexivity. + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Ptrofs.sub_add_opp. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 (Int64.mul i n)) (Int64.mul i n)). + rewrite (Ptrofs.agree64_of_int ARCHI64 (Int64.neg (Int64.mul i n))). + reflexivity. + apply (Ptrofs.agree64_of_int ARCHI64). - TrivialExists. Qed. @@ -371,7 +388,7 @@ Proof. auto. } generalize (Int64.one_bits'_decomp n); intros D. destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. -- apply DEFAULT. +- TrivialExists. - replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). apply eval_shllimm; auto. simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. @@ -389,7 +406,7 @@ Proof. rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). inv B1; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. -- apply DEFAULT. +- TrivialExists. Qed. Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). -- cgit From 2c428ad4e0177756db2f6dfe56831b5a44f6de5c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 15:20:02 +0200 Subject: add with shift, beginning --- mppa_k1c/Asmvliw.v | 4 ++-- mppa_k1c/ExtValues.v | 24 ++++++++++++++++++++++++ mppa_k1c/Op.v | 7 ++++--- mppa_k1c/PostpassSchedulingOracle.ml | 9 ++++++--- mppa_k1c/SelectOp.vp | 10 +++++++++- mppa_k1c/SelectOpproof.v | 36 ++++++++++++++++++++++++++++++++++++ mppa_k1c/ValueAOp.v | 9 +++++---- 7 files changed, 86 insertions(+), 13 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c1f21f8d..e1a7f916 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1068,7 +1068,7 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 - | Paddxw shift => Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) + | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) @@ -1099,7 +1099,7 @@ Definition arith_eval_rri32 n v i := | Psrxil => ExtValues.val_shrxl v (Vint i) | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) - | Paddxiw shift => Val.add (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) | Prevsubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) end. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 735d5c3c..32d84b60 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -13,6 +13,28 @@ Definition z_of_shift1_4 (x : shift1_4) := | SHIFT4 => 4 end. +Definition shift1_4_of_z (x : Z) := + if Z.eq_dec x 1 then Some SHIFT1 + else if Z.eq_dec x 2 then Some SHIFT2 + else if Z.eq_dec x 3 then Some SHIFT3 + else if Z.eq_dec x 4 then Some SHIFT4 + else None. + +Lemma shift1_4_of_z_correct : + forall z, + match shift1_4_of_z z with + | Some x => z_of_shift1_4 x = z + | None => True + end. +Proof. + intro. unfold shift1_4_of_z. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + trivial. +Qed. + Definition int_of_shift1_4 (x : shift1_4) := Int.repr (z_of_shift1_4 x). @@ -178,3 +200,5 @@ Proof. apply Int64.neg_mul_distr_r. Qed. +Definition addx sh v1 v2 := + Val.add v2 (Val.shl v1 (Vint sh)). \ No newline at end of file diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index ac40c293..69620934 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -403,8 +403,8 @@ Definition eval_operation | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) - | Oaddx shift, v1 :: v2 :: nil => Some (Val.add v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) - | Oaddximm shift n, v1 :: nil => Some (Val.add (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Oaddx s14, v1 :: v2 :: nil => Some (addx (int_of_shift1_4 s14) v1 v2) + | Oaddximm s14 n, v1 :: nil => Some (addx (int_of_shift1_4 s14) v1 (Vint n)) | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) @@ -1446,7 +1446,8 @@ Proof. (* addx, addximm *) - apply Val.add_inject; trivial. inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - inv H4; simpl; trivial. try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. (* neg, sub *) - inv H4; simpl; auto. - apply Val.sub_inject; auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index f428fe49..3618969a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -466,6 +466,7 @@ type real_instruction = | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd | Maddw | Maddd | Msbfw | Msbfd | Cmoved | Make | Nop | Extfz | Extfs | Insf + | Addxw | Addxd (* LSU *) | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo | Sb | Sh | Sw | Sd | Sq | So @@ -479,6 +480,8 @@ type real_instruction = let ab_inst_to_real = function | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw + | "Paddxw" | "Paddxiw" -> Addxw + | "Paddxl" | "Paddxil" -> Addxd | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd | "Pandw" | "Pandiw" -> Andw | "Pnandw" | "Pnandiw" -> Nandw @@ -585,12 +588,12 @@ let rec_to_usage r = and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw -> + | Nxorw | Andnw | Ornw | Addxw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved -> + | Nxord | Andnd | Ornd | Cmoved | Addxd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) @@ -643,7 +646,7 @@ let real_inst_to_latency = function | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Srad | Srsd | Srld | Slld | Xord | Make - | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved + | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 81e288cb..ae9d64b9 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -114,6 +114,12 @@ Nondetfunction addimm (n: int) (e: expr) := | _ => Eop (Oaddimm n) (e ::: Enil) end. +Definition add_shlimm n e1 e2 := + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) + | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) + end. + Nondetfunction add (e1: expr) (e2: expr) := match e1, e2 with | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 @@ -135,7 +141,9 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, (Eop (Omulimm n) (t2:::Enil)) => Eop (Omaddimm n) (t1:::t2:::Enil) | (Eop (Omulimm n) (t2:::Enil)), t1 => - Eop (Omaddimm n) (t1:::t2:::Enil) + Eop (Omaddimm n) (t1:::t2:::Enil) + | (Eop (Oshlimm n) (t1:::Enil)), t2 => + add_shlimm n t1 t2 | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 17024826..7b026bf5 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -201,6 +201,37 @@ Proof. + TrivialExists. Qed. +Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n). +Proof. + red. + intros. + unfold add_shlimm. + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + - TrivialExists; + repeat econstructor; eassumption. +Qed. + Theorem eval_add: binary_constructor_sound add Val.add. Proof. red; intros until y. @@ -238,6 +269,11 @@ Proof. subst. TrivialExists. - (* Omaddimm rev *) subst. rewrite Val.add_commut. TrivialExists. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + rewrite Val.add_commut. + apply ADDX; assumption. - TrivialExists. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index adc27010..1f47fd8f 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -371,19 +371,20 @@ Theorem eval_static_operation_sound: list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. - unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros; - destruct op; try (InvHyps; eauto with va). + unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros. + destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - rewrite Ptrofs.add_zero_l; eauto with va. - - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + - unfold addx. eauto with va. + - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with | Vint n2 => Vint (Int.add n n2) | Vptr b2 ofs2 => if Archi.ptr64 then Vundef else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n)) | _ => Vundef - end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. - (*revsubimm*) inv H1; constructor. -- cgit From a17d3c0419ef5531142c4826d962009c9ba81fbc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 17:03:50 +0200 Subject: maddx ordre opposé MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 4 ++++ 2 files changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index ae9d64b9..61365be2 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -144,6 +144,8 @@ Nondetfunction add (e1: expr) (e2: expr) := Eop (Omaddimm n) (t1:::t2:::Enil) | (Eop (Oshlimm n) (t1:::Enil)), t2 => add_shlimm n t1 t2 + | t2, (Eop (Oshlimm n) (t1:::Enil)) => + add_shlimm n t1 t2 | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7b026bf5..583b6f02 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -274,6 +274,10 @@ Proof. unfold binary_constructor_sound in ADDX. rewrite Val.add_commut. apply ADDX; assumption. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + apply ADDX; assumption. - TrivialExists. Qed. -- cgit From a095ac045485f5693d937864f7990ab5de427f1d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 17:46:45 +0200 Subject: more maddx --- mppa_k1c/SelectOp.vp | 8 ++++++ mppa_k1c/SelectOpproof.v | 66 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 74 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 61365be2..9b4cfeb0 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -104,6 +104,12 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) +Definition addimm_shlimm sh k2 e1 := + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) + | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) + end. + Nondetfunction addimm (n: int) (e: expr) := if Int.eq n Int.zero then e else match e with @@ -111,6 +117,8 @@ Nondetfunction addimm (n: int) (e: expr) := | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | Eop (Oshlimm sh) (t1:::Enil) => + addimm_shlimm sh n t1 | _ => Eop (Oaddimm n) (e ::: Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 583b6f02..25b34fb9 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -183,6 +183,66 @@ Proof. auto. Qed. +Theorem eval_addimm_shlimm: + forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)). +Proof. + red; unfold addimm_shlimm; intros. + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. +Qed. + Theorem eval_addimm: forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). Proof. @@ -198,6 +258,12 @@ Proof. + econstructor; split. EvalOp. simpl; eauto. destruct sp; simpl; auto. + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + pose proof eval_addimm_shlimm as ADDX. + unfold unary_constructor_sound in ADDX. + unfold addx in ADDX. + rewrite Val.add_commut. + subst x. + apply ADDX; assumption. + TrivialExists. Qed. -- cgit From 17a8d91a82f67d7f62f8cbad41ba76a4b0b82a30 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 20:17:09 +0200 Subject: apply .xs onto addx4 etc --- mppa_k1c/Asmblockgen.v | 6 ++ mppa_k1c/Asmvliw.v | 2 +- mppa_k1c/ExtValues.v | 5 +- mppa_k1c/Op.v | 4 +- mppa_k1c/PostpassSchedulingOracle.ml | 20 +++++-- mppa_k1c/SelectLong.vp | 17 ++++++ mppa_k1c/SelectLongproof.v | 107 +++++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 13 +++-- mppa_k1c/SelectOpproof.v | 29 ++++++---- mppa_k1c/ValueAOp.v | 4 +- 10 files changed, 180 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 7be83962..71af4798 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -449,6 +449,12 @@ Definition transl_op | Oaddximm shift n, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Paddxiw shift rd rs n ::i k) + | Oaddxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxl shift rd rs1 rs2 ::i k) + | Oaddxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxil shift rd rs n ::i k) | Oneg, a1 :: nil => do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pnegw rd rs ::i k) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e1a7f916..9a933741 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1069,7 +1069,7 @@ Definition arith_eval_rrr n v1 v2 := | Pfmulw => Val.mulfs v1 v2 | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 - | Paddxl shift => Val.addl v1 (Val.shll v1 (Vint (int_of_shift1_4 shift))) + | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 32d84b60..284d55f3 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -201,4 +201,7 @@ Proof. Qed. Definition addx sh v1 v2 := - Val.add v2 (Val.shl v1 (Vint sh)). \ No newline at end of file + Val.add v2 (Val.shl v1 (Vint sh)). + +Definition addxl sh v1 v2 := + Val.addl v2 (Val.shll v1 (Vint sh)). \ No newline at end of file diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 69620934..98635677 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -454,8 +454,8 @@ Definition eval_operation | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) - | Oaddxl shift, v1 :: v2 :: nil => Some (Val.addl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) - | Oaddxlimm shift n, v1 :: nil => Some (Val.addl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Oaddxl s14, v1 :: v2 :: nil => Some (addxl (int_of_shift1_4 s14) v1 v2) + | Oaddxlimm s14 n, v1 :: nil => Some (addxl (int_of_shift1_4 s14) v1 (Vlong n)) | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3618969a..24087caf 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -405,6 +405,10 @@ let alu_lite_x : int array = let resmap = fun r -> match r with | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let alu_lite_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + let alu_full : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) @@ -588,15 +592,23 @@ let rec_to_usage r = and real_inst = ab_inst_to_real r.inst in match real_inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw | Addxw -> + | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved | Addxd -> + | Nxord | Andnd | Ornd | Cmoved -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) + | Addxw -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Addxd -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) | Compw -> (match encoding with None -> alu_tiny | Some U6 | Some S10 | Some U27L5 -> alu_tiny_x | _ -> raise InvalidEncoding) @@ -620,9 +632,9 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop - | Sraw | Srlw | Srsw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) (* TODO: check *) - | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) + | Srsw | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index b29b9712..fe739a01 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -66,6 +66,12 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) +Definition addlimm_shllimm sh k2 e1 := + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) + | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) + end. + Nondetfunction addlimm (n: int64) (e: expr) := if Int64.eq n Int64.zero then e else match e with @@ -76,9 +82,16 @@ Nondetfunction addlimm (n: int64) (e: expr) := else Eop (Oaddlimm n) (e ::: Enil)) | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 | _ => Eop (Oaddlimm n) (e ::: Enil) end. +Definition addl_shllimm n e1 e2 := + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) + | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) + end. + Nondetfunction addl (e1: expr) (e2: expr) := if Archi.splitlong then SplitLong.addl e1 e2 else match e1, e2 with @@ -102,6 +115,10 @@ Nondetfunction addl (e1: expr) (e2: expr) := Eop (Omaddlimm n) (t1:::t2:::Enil) | (Eop (Omullimm n) (t2:::Enil)), t1 => Eop (Omaddlimm n) (t1:::t2:::Enil) + | (Eop (Oshllimm n) (t1:::Enil)), t2 => + addl_shllimm n t1 t2 + | t2, (Eop (Oshllimm n) (t1:::Enil)) => + addl_shllimm n t1 t2 | _, _ => Eop Oaddl (e1:::e2:::Enil) end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 257c7fd9..3c9f64d5 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -119,6 +119,67 @@ Proof. - TrivialExists. Qed. + +Theorem eval_addlimm_shllimm: + forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)). +Proof. + red; unfold addlimm_shllimm; intros. + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. +Qed. + Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). Proof. unfold addlimm; intros; red; intros. @@ -136,9 +197,47 @@ Proof. destruct sp; simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. - subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. +- pose proof eval_addlimm_shllimm as ADDXL. + unfold unary_constructor_sound in ADDXL. + unfold addxl in ADDXL. + rewrite Val.addl_commut. + subst x. + apply ADDXL; assumption. - TrivialExists. Qed. +Lemma eval_addxl: forall n, binary_constructor_sound (addl_shllimm n) (ExtValues.addxl n). +Proof. + red. + intros. + unfold addl_shllimm. + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + (* Oaddxl *) + - TrivialExists; + repeat econstructor; eassumption. +Qed. + Theorem eval_addl: binary_constructor_sound addl Val.addl. Proof. unfold addl. destruct Archi.splitlong eqn:SL. @@ -193,6 +292,14 @@ Proof. - subst. rewrite Val.addl_commut. TrivialExists. - subst. TrivialExists. - subst. rewrite Val.addl_commut. TrivialExists. + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + rewrite Val.addl_commut. + apply ADDXL; assumption. + (* Oaddxl *) + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + apply ADDXL; assumption. - TrivialExists. Qed. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 9b4cfeb0..3427dda3 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -611,13 +611,14 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := else (Aglobal id ofs, Enil)) | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) - | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => + | Eop (Oaddxl sh) (e1:::e2:::Enil) => + let zscale := ExtValues.z_of_shift1_4 sh in + let scale := Int.repr zscale in (if Compopts.optim_fxsaddr tt - then let zscale := Int.unsigned scale in - if Z.eq_dec zscale (zscale_of_chunk chunk) - then (Aindexed2XS zscale, e1:::e2:::Enil) - else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) - else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)) + then if Z.eq_dec zscale (zscale_of_chunk chunk) + then (Aindexed2XS zscale, e2:::e1:::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil)) | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) | _ => (Aindexed Ptrofs.zero, e:::Enil) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 25b34fb9..8e1812c6 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1377,18 +1377,25 @@ Proof. - exists (v1 :: nil); split. eauto with evalexpr. simpl. destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. simpl. auto. - - destruct (Compopts.optim_fxsaddr tt). - + destruct (Z.eq_dec _ _). - * exists (v1 :: v2 :: nil); split. - repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. - * exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. - simpl. congruence. - + exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. + - unfold addxl in *. + destruct (Compopts.optim_fxsaddr tt). + + unfold int_of_shift1_4 in *. + destruct (Z.eq_dec _ _). + * exists (v0 :: v1 :: nil); split. + repeat (constructor; auto). simpl. + congruence. + * eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. simpl. congruence. + + eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. + simpl. unfold int_of_shift1_4 in *. congruence. - exists (v1 :: v0 :: nil); split. repeat (constructor; auto). simpl. congruence. - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. Qed. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 1f47fd8f..10f25701 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -394,6 +394,7 @@ Proof. end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. + - unfold addxl. eauto with va. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.add n n2) | Vptr b2 ofs2 => @@ -401,8 +402,7 @@ Proof. then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) else Vundef | _ => Vundef - end) with - (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. - inv H1; constructor. -- cgit From 66ee59d3dc8a861b468cfaf0ff46fc71dfb8fec2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 21:54:18 +0200 Subject: option -faddx (off by default until questions cleared) --- mppa_k1c/SelectLong.vp | 22 ++++++++++++++-------- mppa_k1c/SelectLongproof.v | 19 +++++++++++++++++-- mppa_k1c/SelectOp.vp | 29 +++++++++++++++++++++-------- mppa_k1c/SelectOpproof.v | 31 +++++++++++++++++++++++++++++-- 4 files changed, 81 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index fe739a01..2450ab97 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -67,10 +67,13 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) Definition addlimm_shllimm sh k2 e1 := - match shift1_4_of_z (Int.unsigned sh) with - | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) - | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) - end. + if Compopts.optim_faddx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) + | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil). Nondetfunction addlimm (n: int64) (e: expr) := if Int64.eq n Int64.zero then e else @@ -87,10 +90,13 @@ Nondetfunction addlimm (n: int64) (e: expr) := end. Definition addl_shllimm n e1 e2 := - match shift1_4_of_z (Int.unsigned n) with - | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) - | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) - end. + if Compopts.optim_faddx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) + | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) + end + else Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil). Nondetfunction addl (e1: expr) (e2: expr) := if Archi.splitlong then SplitLong.addl e1 e2 else diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 3c9f64d5..58a4c39a 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -124,6 +124,8 @@ Theorem eval_addlimm_shllimm: forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)). Proof. red; unfold addlimm_shllimm; intros. + destruct (Compopts.optim_addx tt). + { destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. - TrivialExists. simpl. f_equal. @@ -178,6 +180,13 @@ Proof. repeat (try eassumption; try econstructor). simpl. reflexivity. + } + { unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } Qed. Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). @@ -188,7 +197,7 @@ Proof. destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. destruct (addlimm_match a); InvEval. - econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. -- destruct (Compopts.optim_fglobaladdroffset _). +- destruct (Compopts.optim_globaladdroffset _). + econstructor; split. EvalOp. simpl; eauto. unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto. @@ -211,6 +220,8 @@ Proof. red. intros. unfold addl_shllimm. + destruct (Compopts.optim_addx tt). + { destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. - TrivialExists. simpl. @@ -235,7 +246,11 @@ Proof. discriminate. (* Oaddxl *) - TrivialExists; - repeat econstructor; eassumption. + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } Qed. Theorem eval_addl: binary_constructor_sound addl Val.addl. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3427dda3..4d2a948d 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -105,10 +105,13 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) Definition addimm_shlimm sh k2 e1 := - match shift1_4_of_z (Int.unsigned sh) with - | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) - | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) - end. + if Compopts.optim_faddx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) + | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil). Nondetfunction addimm (n: int) (e: expr) := if Int.eq n Int.zero then e else @@ -123,10 +126,13 @@ Nondetfunction addimm (n: int) (e: expr) := end. Definition add_shlimm n e1 e2 := - match shift1_4_of_z (Int.unsigned n) with - | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) - | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) - end. + if Compopts.optim_faddx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) + | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) + end + else Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil). Nondetfunction add (e1: expr) (e2: expr) := match e1, e2 with @@ -611,6 +617,13 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := else (Aglobal id ofs, Enil)) | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => + (if Compopts.optim_fxsaddr tt + then let zscale := Int.unsigned scale in + if Z.eq_dec zscale (zscale_of_chunk chunk) + then (Aindexed2XS zscale, e1:::e2:::Enil) + else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) + else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)) | Eop (Oaddxl sh) (e1:::e2:::Enil) => let zscale := ExtValues.z_of_shift1_4 sh in let scale := Int.repr zscale in diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 8e1812c6..f5a90803 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -187,6 +187,8 @@ Theorem eval_addimm_shlimm: forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)). Proof. red; unfold addimm_shlimm; intros. + destruct (Compopts.optim_addx tt). + { destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. - TrivialExists. simpl. f_equal. @@ -241,6 +243,13 @@ Proof. repeat (try eassumption; try econstructor). simpl. reflexivity. + } + { unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } Qed. Theorem eval_addimm: @@ -272,6 +281,8 @@ Proof. red. intros. unfold add_shlimm. + destruct (Compopts.optim_addx tt). + { destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. - TrivialExists. simpl. @@ -295,7 +306,11 @@ Proof. apply Int.repr_unsigned. } discriminate. - TrivialExists; - repeat econstructor; eassumption. + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } Qed. Theorem eval_add: binary_constructor_sound add Val.add. @@ -1377,8 +1392,20 @@ Proof. - exists (v1 :: nil); split. eauto with evalexpr. simpl. destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. simpl. auto. + - destruct (Compopts.optim_xsaddr tt). + + destruct (Z.eq_dec _ _). + * exists (v1 :: v2 :: nil); split. + repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. + * exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. + + exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. - unfold addxl in *. - destruct (Compopts.optim_fxsaddr tt). + destruct (Compopts.optim_xsaddr tt). + unfold int_of_shift1_4 in *. destruct (Z.eq_dec _ _). * exists (v0 :: v1 :: nil); split. -- cgit From 005093b87250b6b27b320eb789574da4bda616c0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 May 2019 22:40:50 +0200 Subject: correct -faddx option and propagate addim over addxim --- mppa_k1c/SelectLong.vp | 7 ++++--- mppa_k1c/SelectLongproof.v | 5 +++++ mppa_k1c/SelectOp.vp | 14 +++++++------- mppa_k1c/SelectOpproof.v | 5 +++++ 4 files changed, 21 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 2450ab97..4e369e11 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -67,7 +67,7 @@ Definition longofintu (e: expr) := (** ** Integer addition and pointer addition *) Definition addlimm_shllimm sh k2 e1 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned sh) with | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) @@ -80,17 +80,18 @@ Nondetfunction addlimm (n: int64) (e: expr) := match e with | Eop (Olongconst m) Enil => longconst (Int64.add n m) | Eop (Oaddrsymbol s m) Enil => - (if Compopts.optim_fglobaladdroffset tt + (if Compopts.optim_globaladdroffset tt then Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil else Eop (Oaddlimm n) (e ::: Enil)) | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | Eop (Oaddxlimm sh m) (t ::: Enil) => Eop (Oaddxlimm sh (Int64.add n m)) (t ::: Enil) | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 | _ => Eop (Oaddlimm n) (e ::: Enil) end. Definition addl_shllimm n e1 e2 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned n) with | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 58a4c39a..78a2bb31 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -206,6 +206,11 @@ Proof. destruct sp; simpl; auto. destruct Archi.ptr64; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. - subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. +- TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int64.add_assoc. rewrite Int64.add_commut. + reflexivity. - pose proof eval_addlimm_shllimm as ADDXL. unfold unary_constructor_sound in ADDXL. unfold addxl in ADDXL. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 4d2a948d..7cf300f8 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -105,7 +105,7 @@ Definition addrstack (ofs: ptrofs) := (** ** Integer addition and pointer addition *) Definition addimm_shlimm sh k2 e1 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned sh) with | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) @@ -120,13 +120,13 @@ Nondetfunction addimm (n: int) (e: expr) := | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | Eop (Oshlimm sh) (t1:::Enil) => - addimm_shlimm sh n t1 + | Eop (Oaddximm sh m) (t ::: Enil) => Eop (Oaddximm sh (Int.add n m)) (t ::: Enil) + | Eop (Oshlimm sh) (t1:::Enil) => addimm_shlimm sh n t1 | _ => Eop (Oaddimm n) (e ::: Enil) end. Definition add_shlimm n e1 e2 := - if Compopts.optim_faddx tt + if Compopts.optim_addx tt then match shift1_4_of_z (Int.unsigned n) with | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) @@ -612,13 +612,13 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := match e with | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) | Eop (Oaddrsymbol id ofs) Enil => - (if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp tt))) + (if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) then (Aindexed Ptrofs.zero, e:::Enil) else (Aglobal id ofs, Enil)) | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => - (if Compopts.optim_fxsaddr tt + (if Compopts.optim_xsaddr tt then let zscale := Int.unsigned scale in if Z.eq_dec zscale (zscale_of_chunk chunk) then (Aindexed2XS zscale, e1:::e2:::Enil) @@ -627,7 +627,7 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) := | Eop (Oaddxl sh) (e1:::e2:::Enil) => let zscale := ExtValues.z_of_shift1_4 sh in let scale := Int.repr zscale in - (if Compopts.optim_fxsaddr tt + (if Compopts.optim_xsaddr tt then if Z.eq_dec zscale (zscale_of_chunk chunk) then (Aindexed2XS zscale, e2:::e1:::Enil) else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index f5a90803..ad7e4209 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -267,6 +267,11 @@ Proof. + econstructor; split. EvalOp. simpl; eauto. destruct sp; simpl; auto. + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int.add_assoc. rewrite Int.add_commut. + reflexivity. + pose proof eval_addimm_shlimm as ADDX. unfold unary_constructor_sound in ADDX. unfold addx in ADDX. -- cgit From 644814b1b266f5492e6ffd24776fc87c30acd57b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 May 2019 12:41:49 +0200 Subject: standardize semantics, 1 --- mppa_k1c/Asmvliw.v | 11 +++++------ mppa_k1c/ExtValues.v | 8 +++++++- 2 files changed, 12 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 9a933741..886228ad 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1071,9 +1071,8 @@ Definition arith_eval_rrr n v1 v2 := | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 - | Prevsubxw shift => Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift))) - - | Prevsubxl shift => Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift))) + | Prevsubxw shift => ExtValues.revsubx (int_of_shift1_4 shift) v1 v2 + | Prevsubxl shift => ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2 end. Definition arith_eval_rri32 n v i := @@ -1100,7 +1099,7 @@ Definition arith_eval_rri32 n v i := | Psrlil => Val.shrlu v (Vint i) | Psrail => Val.shrl v (Vint i) | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) - | Prevsubxiw shift => Val.sub (Vint i) (Val.shl v (Vint (int_of_shift1_4 shift))) + | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i) end. Definition arith_eval_rri64 n v i := @@ -1117,8 +1116,8 @@ Definition arith_eval_rri64 n v i := | Pnxoril => Val.notl (Val.xorl v (Vlong i)) | Pandnil => Val.andl (Val.notl v) (Vlong i) | Pornil => Val.orl (Val.notl v) (Vlong i) - | Paddxil shift => Val.addl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) - | Prevsubxil shift => Val.subl (Vlong i) (Val.shll v (Vint (int_of_shift1_4 shift))) + | Paddxil shift => ExtValues.addxl (int_of_shift1_4 shift) v (Vlong i) + | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i) end. Definition arith_eval_arrr n v1 v2 v3 := diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 284d55f3..9169cf13 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -204,4 +204,10 @@ Definition addx sh v1 v2 := Val.add v2 (Val.shl v1 (Vint sh)). Definition addxl sh v1 v2 := - Val.addl v2 (Val.shll v1 (Vint sh)). \ No newline at end of file + Val.addl v2 (Val.shll v1 (Vint sh)). + +Definition revsubx sh v1 v2 := + Val.sub v2 (Val.shl v1 (Vint sh)). + +Definition revsubxl sh v1 v2 := + Val.subl v2 (Val.shll v1 (Vint sh)). \ No newline at end of file -- cgit From 26428dbaa2f3fec4b8fd121fc6e53a22a5cc5c5d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 May 2019 13:01:06 +0200 Subject: standardization of expressions --- mppa_k1c/Op.v | 8 ++++---- mppa_k1c/ValueAOp.v | 10 ++++------ 2 files changed, 8 insertions(+), 10 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 98635677..4df157b0 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -408,8 +408,8 @@ Definition eval_operation | Oneg, v1 :: nil => Some (Val.neg v1) | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) - | Orevsubx shift, v1 :: v2 :: nil => Some (Val.sub v2 (Val.shl v1 (Vint (int_of_shift1_4 shift)))) - | Orevsubximm shift n, v1 :: nil => Some (Val.sub (Vint n) (Val.shl v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubx shift, v1 :: v2 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 v2) + | Orevsubximm shift n, v1 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 (Vint n)) | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) @@ -459,8 +459,8 @@ Definition eval_operation | Onegl, v1::nil => Some (Val.negl v1) | Osubl, v1::v2::nil => Some (Val.subl v1 v2) | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) - | Orevsubxl shift, v1 :: v2 :: nil => Some (Val.subl v2 (Val.shll v1 (Vint (int_of_shift1_4 shift)))) - | Orevsubxlimm shift n, v1 :: nil => Some (Val.subl (Vlong n) (Val.shll v1 (Vint (int_of_shift1_4 shift)))) + | Orevsubxl shift, v1 :: v2 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2) + | Orevsubxlimm shift n, v1 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 (Vlong n)) | Omull, v1::v2::nil => Some (Val.mull v1 v2) | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 10f25701..f41dae63 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -371,12 +371,11 @@ Theorem eval_static_operation_sound: list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. - unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros. + unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs, addx, revsubx, addxl, revsubxl; intros. destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. - rewrite Ptrofs.add_zero_l; eauto with va. - - unfold addx. eauto with va. - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with | Vint n2 => Vint (Int.add n n2) | Vptr b2 ofs2 => @@ -389,12 +388,11 @@ Proof. + destruct a1; destruct shift; reflexivity. - (*revsubimm*) inv H1; constructor. - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with - | Vint n2 => Vint (Int.sub n n2) - | _ => Vundef + | Vint n2 => Vint (Int.sub n n2) + | _ => Vundef end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. - + destruct a1; destruct shift; reflexivity. - - unfold addxl. eauto with va. + + destruct n; destruct shift; reflexivity. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.add n n2) | Vptr b2 ofs2 => -- cgit From fd7a801bef1e9fe6e47b62c5c1b0905a4dde7ae8 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 26 May 2019 08:50:44 +0200 Subject: extending bblock_simu_test with rewriting --- mppa_k1c/Asmblockdeps.v | 63 +- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 130 ++- mppa_k1c/abstractbb/DepTreeTheory.v | 456 -------- mppa_k1c/abstractbb/ImpDep.v | 960 ----------------- mppa_k1c/abstractbb/ImpSimuTest.v | 1108 ++++++++++++++++++++ mppa_k1c/abstractbb/Impure/ImpCore.v | 2 +- mppa_k1c/abstractbb/Impure/ImpHCons.v | 104 +- mppa_k1c/abstractbb/Impure/ImpLoops.v | 8 +- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 51 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 37 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 5 +- mppa_k1c/abstractbb/Parallelizability.v | 4 +- mppa_k1c/abstractbb/SeqSimuTheory.v | 428 ++++++++ 13 files changed, 1825 insertions(+), 1531 deletions(-) delete mode 100644 mppa_k1c/abstractbb/DepTreeTheory.v delete mode 100644 mppa_k1c/abstractbb/ImpDep.v create mode 100644 mppa_k1c/abstractbb/ImpSimuTest.v create mode 100644 mppa_k1c/abstractbb/SeqSimuTheory.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index eb3900d5..e0aaee58 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -9,7 +9,7 @@ Require Import Integers. Require Import Floats. Require Import ZArith. Require Import Coqlib. -Require Import ImpDep. +Require Import ImpSimuTest. Require Import Axioms. Require Import Parallelizability. Require Import Asmvliw Permutation. @@ -302,30 +302,6 @@ Definition op_eval (o: op) (l: list value) := end. - (** Function [is_constant] is used for a small optimization inside the scheduling verifier. - It is good that it answers [true] as much as possible while satisfying [is_constant_correct] below. - - BE CAREFUL that, [is_constant] must not depend on [ge]. - Otherwise, we would have an easy implementation: [match op_eval o nil with Some _ => true | _ => false end] - - => REM: when [is_constant] is not complete w.r.t [is_constant_correct], this should have only a very little impact - on the performance of the scheduling verifier... - *) - -Definition is_constant (o: op): bool := - match o with - | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true - | _ => false - end. - -Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None. -Proof. - destruct o; simpl; try congruence. - destruct ao; simpl; try congruence; - destruct n; simpl; try congruence; - unfold arith_eval; destruct Ge; simpl; try congruence. -Qed. - Definition arith_op_eq (o1 o2: arith_op): ?? bool := match o1 with | OArithR n1 => @@ -507,7 +483,7 @@ Include MkSeqLanguage P. End L. -Module IDT := ImpDepTree L ImpPosDict. +Module IST := ImpSimu L ImpPosDict. Import L. Import P. @@ -1593,16 +1569,35 @@ Definition string_of_op (op: P.op): ?? pstring := | Fail => RET (Str "Fail") end. +End SECT_BBLOCK_EQUIV. + +(** REWRITE RULES *) + +Definition is_constant (o: op): bool := + match o with + | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true + | _ => false + end. + +Program Definition failsafe_reduce := Terms.failsafe_reduce is_constant. +Obligation 1. + destruct o; simpl in * |- *; try congruence. + destruct ao; simpl in * |- *; try congruence; + destruct n; simpl in * |- *; try congruence; + unfold arith_eval; destruct ge; simpl in * |- *; try congruence. +Qed. + + Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then - IDT.verb_bblock_simu_test string_of_name string_of_op (trans_block p1) (trans_block p2) + IST.verb_bblock_simu_test failsafe_reduce string_of_name string_of_op (trans_block p1) (trans_block p2) else - IDT.bblock_simu_test (trans_block p1) (trans_block p2). + IST.bblock_simu_test failsafe_reduce (trans_block p1) (trans_block p2). -Local Hint Resolve IDT.bblock_simu_test_correct bblock_simu_reduce IDT.verb_bblock_simu_test_correct: wlp. +Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. Theorem bblock_simu_test_correct verb p1 p2 : - WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_simu ge fn p1 p2. + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. wlp_simplify. Qed. @@ -1614,7 +1609,7 @@ Import UnsafeImpure. Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: Ge = Genv ge fn -> pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. @@ -1622,9 +1617,7 @@ Qed. Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Lemma bblock_simub_correct p1 p2 ge fn: Ge = Genv ge fn -> bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). -Qed. - -End SECT_BBLOCK_EQUIV. +Qed. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 618f3ebe..f381c810 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,6 +1,6 @@ (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) - +Require Import ImpPrelude. Module Type PseudoRegisters. @@ -24,16 +24,8 @@ Parameter op: Type. (* type of operations *) Parameter genv: Type. (* environment to be used for evaluating an op *) -(* NB: possible generalization - - relation after/before. -*) Parameter op_eval: genv -> op -> list value -> option value. -Parameter is_constant: op -> bool. - -Parameter is_constant_correct: - forall ge o, is_constant o = true -> op_eval ge o nil <> None. - End LangParam. @@ -54,6 +46,9 @@ Definition mem := R.t -> value. Definition assign (m: mem) (x:R.t) (v: value): mem := fun y => if R.eq_dec x y then v else m y. + +(** expressions *) + Inductive exp := | PReg (x:R.t) | Op (o:op) (le: list_exp) @@ -140,7 +135,7 @@ Proof. Qed. -(** A small theory of bblock equality *) +(** A small theory of bblock simulation *) (* equalities on bblock outputs *) Definition res_eq (om1 om2: option mem): Prop := @@ -240,6 +235,121 @@ Qed. End SEQLANG. +Module Terms. + +(** terms in the symbolic evaluation +NB: such a term represents the successive computations in one given pseudo-register +*) + +Inductive term := + | Input (x:R.t) (hid:hashcode) + | App (o: op) (l: list_term) (hid:hashcode) +with list_term := + | LTnil (hid:hashcode) + | LTcons (t:term) (l:list_term) (hid:hashcode) + . + +Scheme term_mut := Induction for term Sort Prop +with list_term_mut := Induction for list_term Sort Prop. + +Bind Scope pattern_scope with term. +Delimit Scope term_scope with term. +Delimit Scope pattern_scope with pattern. + +Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope. +Notation "[ x ]" := (LTcons x [] _): pattern_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope. +Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope. + +Import HConsingDefs. + +Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope. +Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope. +Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope. + +Local Open Scope pattern_scope. + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x _ => Some (m x) + | o @ l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | [] => Some nil + | LTcons t l' _ => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + + +Definition term_get_hid (t: term): hashcode := + match t with + | Input _ hid => hid + | App _ _ hid => hid + end. + +Definition list_term_get_hid (l: list_term): hashcode := + match l with + | LTnil hid => hid + | LTcons _ _ hid => hid + end. + + +Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. + +Record pseudo_term: Type := { + valid: list term; + effect: term +}. + +Definition match_pseudo_term (t: term) (pt: pseudo_term) := + (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(valid) m) + /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). + +Import ImpCore.Notations. +Local Open Scope impure_scope. + +Record reduction (t:term):= { + result:> ?? pseudo_term; + result_correct: WHEN result ~> pt THEN match_pseudo_term t pt; +}. +Hint Resolve result_correct: wlp. + +Program Definition identity_reduce (t: term): reduction t := {| result := RET {| valid := [t]; effect := t |} |}. +Obligation 1. + unfold match_pseudo_term, allvalid; wlp_simplify; congruence. +Qed. +Global Opaque identity_reduce. + +Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := + match t with + | Input x _ => {| result := RET {| valid := []; effect := t |} |} + | o @ [] => match is_constant o with + | true => {| result := RET {| valid := []; effect := t |} |} + | false => identity_reduce t + end + | _ => identity_reduce t + end. +Obligation 1. + unfold match_pseudo_term, allvalid; simpl; wlp_simplify; congruence. +Qed. +Obligation 2. + unfold match_pseudo_term, allvalid; simpl; wlp_simplify. +Qed. +Obligation 3. + intuition congruence. +Qed. + +End Terms. + End MkSeqLanguage. diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v deleted file mode 100644 index c7bed8bf..00000000 --- a/mppa_k1c/abstractbb/DepTreeTheory.v +++ /dev/null @@ -1,456 +0,0 @@ -(** Dependency Trees of Abstract Basic Blocks - -with a purely-functional-but-exponential test. - -*) - - -Require Setoid. (* in order to rewrite <-> *) -Require Export AbstractBasicBlocksDef. -Require Import List. - -Module Type PseudoRegDictionary. - -Declare Module R: PseudoRegisters. - -Parameter t: Type -> Type. - -Parameter get: forall {A}, t A -> R.t -> option A. - -Parameter set: forall {A}, t A -> R.t -> A -> t A. - -Parameter set_spec_eq: forall A d x (v: A), - get (set d x v) x = Some v. - -Parameter set_spec_diff: forall A d x y (v: A), - x <> y -> get (set d x v) y = get d y. - -Parameter empty: forall {A}, t A. - -Parameter empty_spec: forall A x, - get (empty (A:=A)) x = None. - -End PseudoRegDictionary. - - -(** * Computations of "bblock" Dependencies and application to the equality test *) - -Module DepTree (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). - -Export L. -Export LP. - -Section DEPTREE. - -(** Dependency Trees of these "bblocks" - -NB: each tree represents the successive computations in one given resource - -*) - -Inductive tree := - | Tname (x:R.t) - | Top (o: op) (l: list_tree) -with list_tree := - | Tnil: list_tree - | Tcons (t:tree) (l:list_tree): list_tree - . - - -Fixpoint tree_eval (ge: genv) (t: tree) (m: mem): option value := - match t with - | Tname x => Some (m x) - | Top o l => - match list_tree_eval ge l m with - | Some v => op_eval ge o v - | _ => None - end - end -with list_tree_eval ge (l: list_tree) (m: mem) {struct l}: option (list value) := - match l with - | Tnil => Some nil - | Tcons t l' => - match (tree_eval ge t m), (list_tree_eval ge l' m) with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end - end. - -Definition deps_get (d:Dict.t tree) x := - match Dict.get d x with - | None => Tname x - | Some t => t - end. - -Fixpoint exp_tree (e: exp) d old: tree := - match e with - | PReg x => deps_get d x - | Op o le => Top o (list_exp_tree le d old) - | Old e => exp_tree e old old - end -with list_exp_tree (le: list_exp) d old: list_tree := - match le with - | Enil => Tnil - | Econs e le' => Tcons (exp_tree e d old) (list_exp_tree le' d old) - | LOld le => list_exp_tree le old old - end. - -Record deps:= {pre: genv -> mem -> Prop; post: Dict.t tree}. - -Coercion post: deps >-> Dict.t. - -Definition deps_eval ge (d: deps) x (m:mem) := - tree_eval ge (deps_get d x) m. - -Definition deps_set (d:deps) x (t:tree) := - {| pre:=(fun ge m => (deps_eval ge d x m) <> None /\ (d.(pre) ge m)); - post:=Dict.set d x t |}. - -Definition deps_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. - -Variable ge: genv. - -Lemma set_spec_eq d x t m: - deps_eval ge (deps_set d x t) x m = tree_eval ge t m. -Proof. - unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. -Qed. - -Lemma set_spec_diff d x y t m: - x <> y -> deps_eval ge (deps_set d x t) y m = deps_eval ge d y m. -Proof. - intros; unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. -Qed. - -Lemma deps_eval_empty x m: deps_eval ge deps_empty x m = Some (m x). -Proof. - unfold deps_eval, deps_get; rewrite Dict.empty_spec; simpl; auto. -Qed. - -Hint Rewrite set_spec_eq deps_eval_empty: dict_rw. - -Fixpoint inst_deps (i: inst) (d old: deps): deps := - match i with - | nil => d - | (x, e)::i' => - let t:=exp_tree e d old in - inst_deps i' (deps_set d x t) old - end. - -Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps := - match p with - | nil => d - | i::p' => - let d':=inst_deps i d d in - bblock_deps_rec p' d' - end. - -Local Hint Resolve deps_eval_empty. - -Definition bblock_deps: bblock -> deps - := fun p => bblock_deps_rec p deps_empty. - -Lemma inst_deps_pre_monotonic i old: forall d m, - (pre (inst_deps i d old) ge m) -> (pre d ge m). -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d a H; generalize (IHi _ _ H); clear H IHi. - unfold deps_set; simpl; intuition. -Qed. - -Lemma bblock_deps_pre_monotonic p: forall d m, - (pre (bblock_deps_rec p d) ge m) -> (pre d ge m). -Proof. - induction p as [|i p' IHp']; simpl; eauto. - intros d a H; eapply inst_deps_pre_monotonic; eauto. -Qed. - -Local Hint Resolve inst_deps_pre_monotonic bblock_deps_pre_monotonic. - -Lemma tree_eval_exp e od m0 old: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall d m1, - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - tree_eval ge (exp_tree e d od) m0 = exp_eval ge e m1 old. -Proof. - unfold deps_eval in * |- *; intro H. - induction e using exp_mut with - (P0:=fun l => forall (d:deps) m1, (forall x, tree_eval ge (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval ge (list_exp_tree l d od) m0 = list_exp_eval ge l m1 old); - simpl; auto. - - intros; erewrite IHe; eauto. - - intros. erewrite IHe, IHe0; eauto. -Qed. - -Lemma inst_deps_abort i m0 x old: forall d, - pre (inst_deps i d old) ge m0 -> - deps_eval ge d x m0 = None -> - deps_eval ge (inst_deps i d old) x m0 = None. -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d VALID H; erewrite IHi; eauto. clear IHi. - destruct (R.eq_dec x y). - * subst; autorewrite with dict_rw. - generalize (inst_deps_pre_monotonic _ _ _ _ VALID); clear VALID. - unfold deps_set; simpl; intuition congruence. - * rewrite set_spec_diff; auto. -Qed. - -Lemma block_deps_rec_abort p m0 x: forall d, - pre (bblock_deps_rec p d) ge m0 -> - deps_eval ge d x m0 = None -> - deps_eval ge (bblock_deps_rec p d) x m0 = None. -Proof. - induction p; simpl; auto. - intros d VALID H; erewrite IHp; eauto. clear IHp. - eapply inst_deps_abort; eauto. -Qed. - -Lemma inst_deps_Some_correct1 i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) (d: deps), - inst_run ge i m1 old = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x). -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. - refine (IHi _ _ _ _ _ _); eauto. - clear x0; intros x0. - unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. -Qed. - -Lemma bblocks_deps_rec_Some_correct1 p m0: forall (m1 m2: mem) d, - run ge p m1 = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x). -Proof. - Local Hint Resolve inst_deps_Some_correct1. - induction p as [ | i p]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (inst_run ge i m1 m1) eqn: Heqov. - + refine (IHp _ _ _ _ _ _); eauto. - + inversion H. -Qed. - -Lemma bblock_deps_Some_correct1 p m0 m1: - run ge p m0 = Some m1 - -> forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x). -Proof. - intros; eapply bblocks_deps_rec_Some_correct1; eauto. -Qed. - -Lemma inst_deps_None_correct i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall m1 d, pre (inst_deps i d od) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - inst_run ge i m1 old = None -> exists x, deps_eval ge (inst_deps i d od) x m0 = None. -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - - discriminate. - - intros VALID H0. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. - + intuition. - constructor 1 with (x:=x); simpl. - apply inst_deps_abort; auto. - autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. -Qed. - -Lemma inst_deps_Some_correct2 i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) d, - pre (inst_deps i d od) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - (forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x)) -> - res_eq (Some m2) (inst_run ge i m1 old). -Proof. - intro X. - induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst. autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. - + generalize (H x). - rewrite inst_deps_abort; discriminate || auto. - autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. -Qed. - -Lemma bblocks_deps_rec_Some_correct2 p m0: forall (m1 m2: mem) d, - pre (bblock_deps_rec p d) ge m0 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - (forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x)) -> - res_eq (Some m2) (run ge p m1). -Proof. - induction p as [|i p]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (inst_run ge i m1 m1) eqn: Heqom. - + refine (IHp _ _ _ _ _ _); eauto. - + assert (X: exists x, tree_eval ge (deps_get (inst_deps i d d) x) m0 = None). - { eapply inst_deps_None_correct; eauto. } - destruct X as [x H1]. - generalize (H x). - erewrite block_deps_rec_abort; eauto. - congruence. -Qed. - - -Lemma bblock_deps_Some_correct2 p m0 m1: - pre (bblock_deps p) ge m0 -> - (forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x)) - -> res_eq (Some m1) (run ge p m0). -Proof. - intros; eapply bblocks_deps_rec_Some_correct2; eauto. -Qed. - -Lemma inst_valid i m0 old od: - (forall x, deps_eval ge od x m0 = Some (old x)) -> - forall (m1 m2: mem) (d: deps), - pre d ge m0 -> - inst_run ge i m1 old = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - pre (inst_deps i d od) ge m0. -Proof. - induction i as [|[x e] i IHi]; simpl; auto. - intros Hold m1 m2 d VALID0 H Hm1. - destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. - eapply IHi; eauto. - + unfold deps_set in * |- *; simpl. - rewrite Hm1; intuition congruence. - + intros x0. unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite tree_eval_exp; eauto. - * rewrite set_spec_diff; auto. -Qed. - - -Lemma block_deps_rec_valid p m0: forall (m1 m2: mem) (d:deps), - pre d ge m0 -> - run ge p m1 = Some m2 -> - (forall x, deps_eval ge d x m0 = Some (m1 x)) -> - pre (bblock_deps_rec p d) ge m0. -Proof. - Local Hint Resolve inst_valid. - induction p as [ | i p]; simpl; intros m1 d H; auto. - intros H0 H1. - destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. - congruence. -Qed. - -Lemma bblock_deps_valid p m0 m1: - run ge p m0 = Some m1 -> - pre (bblock_deps p) ge m0. -Proof. - intros; eapply block_deps_rec_valid; eauto. - unfold deps_empty; simpl. auto. -Qed. - -Definition valid ge d m := pre d ge m /\ forall x, deps_eval ge d x m <> None. - -Theorem bblock_deps_simu p1 p2: - (forall m, valid ge (bblock_deps p1) m -> valid ge (bblock_deps p2) m) -> - (forall m0 x m1, valid ge (bblock_deps p1) m0 -> deps_eval ge (bblock_deps p1) x m0 = Some m1 -> - deps_eval ge (bblock_deps p2) x m0 = Some m1) -> - bblock_simu ge p1 p2. -Proof. - Local Hint Resolve bblock_deps_valid bblock_deps_Some_correct1. - unfold valid; intros INCL EQUIV m DONTFAIL. - destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. - assert (X: forall x, deps_eval ge (bblock_deps p1) x m = Some (m1 x)); eauto. - eapply bblock_deps_Some_correct2; eauto. - + destruct (INCL m); intuition eauto. - congruence. - + intro x; apply EQUIV; intuition eauto. - congruence. -Qed. - -Lemma valid_set_decompose_1 d t x m: - valid ge (deps_set d x t) m -> valid ge d m. -Proof. - unfold valid; intros ((PRE1 & PRE2) & VALID); split. - + intuition. - + intros x0 H. case (R.eq_dec x x0). - * intuition congruence. - * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. -Qed. - -Lemma valid_set_decompose_2 d t x m: - valid ge (deps_set d x t) m -> tree_eval ge t m <> None. -Proof. - unfold valid; intros ((PRE1 & PRE2) & VALID) H. - generalize (VALID x); autorewrite with dict_rw. - tauto. -Qed. - -Lemma valid_set_proof d x t m: - valid ge d m -> tree_eval ge t m <> None -> valid ge (deps_set d x t) m. -Proof. - unfold valid; intros (PRE & VALID) PREt. split. - + split; auto. - + intros x0; case (R.eq_dec x x0). - - intros; subst; autorewrite with dict_rw. auto. - - intros. rewrite set_spec_diff; auto. -Qed. - -End DEPTREE. - -End DepTree. - -Require Import PArith. -Require Import FMapPositive. - -Module PosDict <: PseudoRegDictionary with Module R:=Pos. - -Module R:=Pos. - -Definition t:=PositiveMap.t. - -Definition get {A} (d:t A) (x:R.t): option A - := PositiveMap.find x d. - -Definition set {A} (d:t A) (x:R.t) (v:A): t A - := PositiveMap.add x v d. - -Local Hint Unfold PositiveMap.E.eq. - -Lemma set_spec_eq A d x (v: A): - get (set d x v) x = Some v. -Proof. - unfold get, set; apply PositiveMap.add_1; auto. -Qed. - -Lemma set_spec_diff A d x y (v: A): - x <> y -> get (set d x v) y = get d y. -Proof. - unfold get, set; intros; apply PositiveMap.gso; auto. -Qed. - -Definition empty {A}: t A := PositiveMap.empty A. - -Lemma empty_spec A x: - get (empty (A:=A)) x = None. -Proof. - unfold get, empty; apply PositiveMap.gempty; auto. -Qed. - -End PosDict. \ No newline at end of file diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v deleted file mode 100644 index eebf396d..00000000 --- a/mppa_k1c/abstractbb/ImpDep.v +++ /dev/null @@ -1,960 +0,0 @@ -(** Dependency Graph of Abstract Basic Blocks - -using imperative hash-consing technique in order to get a linear equivalence test. - -*) - -Require Export Impure.ImpHCons. -Export Notations. - -Require Export DepTreeTheory. - -Require Import PArith. - - -Local Open Scope impure. - -Import ListNotations. -Local Open Scope list_scope. - - -Module Type ImpParam. - -Include LangParam. - -Parameter op_eq: op -> op -> ?? bool. - -Parameter op_eq_correct: forall o1 o2, - WHEN op_eq o1 o2 ~> b THEN - b=true -> o1 = o2. - -End ImpParam. - - -Module Type ISeqLanguage. - -Declare Module LP: ImpParam. - -Include MkSeqLanguage LP. - -End ISeqLanguage. - - -Module Type ImpDict. - -Include PseudoRegDictionary. - -Parameter eq_test: forall {A}, t A -> t A -> ?? bool. - -Parameter eq_test_correct: forall A (d1 d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. - -(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) - - -(* only for debugging *) -Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. - -End ImpDict. - -Module ImpDepTree (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R). - -Module DT := DepTree L Dict. - -Import DT. - -Section CanonBuilding. - -Variable hC_tree: pre_hashV tree -> ?? hashV tree. -Hypothesis hC_tree_correct: forall t, WHEN hC_tree t ~> t' THEN pre_data t=data t'. - -Variable hC_list_tree: pre_hashV list_tree -> ?? hashV list_tree. -Hypothesis hC_list_tree_correct: forall t, WHEN hC_list_tree t ~> t' THEN pre_data t=data t'. - -(* First, we wrap constructors for hashed values !*) - -Local Open Scope positive. -Local Open Scope list_scope. - -Definition hTname (x:R.t) (debug: option pstring): ?? hashV tree := - DO hc <~ hash 1;; - DO hv <~ hash x;; - hC_tree {| pre_data:=Tname x; hcodes :=[hc;hv]; debug_info := debug |}. - -Lemma hTname_correct x dbg: - WHEN hTname x dbg ~> t THEN (data t)=(Tname x). -Proof. - wlp_simplify. -Qed. -Global Opaque hTname. -Hint Resolve hTname_correct: wlp. - -Definition hTop (o:op) (l: hashV list_tree) (debug: option pstring) : ?? hashV tree := - DO hc <~ hash 2;; - DO hv <~ hash o;; - hC_tree {| pre_data:=Top o (data l); - hcodes:=[hc;hv;hid l]; - debug_info := debug |}. - -Lemma hTop_correct o l dbg : - WHEN hTop o l dbg ~> t THEN (data t)=(Top o (data l)). -Proof. - wlp_simplify. -Qed. -Global Opaque hTop. -Hint Resolve hTop_correct: wlp. - -Definition hTnil (_: unit): ?? hashV list_tree := - hC_list_tree {| pre_data:=Tnil; hcodes := nil; debug_info := None |} . - -Lemma hTnil_correct x: - WHEN hTnil x ~> l THEN (data l)=Tnil. -Proof. - wlp_simplify. -Qed. -Global Opaque hTnil. -Hint Resolve hTnil_correct: wlp. - - -Definition hTcons (t: hashV tree) (l: hashV list_tree): ?? hashV list_tree := - hC_list_tree {| pre_data:=Tcons (data t) (data l); hcodes := [hid t; hid l]; debug_info := None |}. - -Lemma hTcons_correct t l: - WHEN hTcons t l ~> l' THEN (data l')=Tcons (data t) (data l). -Proof. - wlp_simplify. -Qed. -Global Opaque hTcons. -Hint Resolve hTcons_correct: wlp. - -(* Second, we use these hashed constructors ! *) - - -Record hdeps:= {hpre: list (hashV tree); hpost: Dict.t (hashV tree)}. - -Coercion hpost: hdeps >-> Dict.t. - -(* pseudo deps_get *) -Definition pdeps_get (d:Dict.t (hashV tree)) x : tree := - match Dict.get d x with - | None => Tname x - | Some t => (data t) - end. - -Definition hdeps_get (d:hdeps) x dbg : ?? hashV tree := - match Dict.get d x with - | None => hTname x dbg - | Some t => RET t - end. - -Lemma hdeps_get_correct (d:hdeps) x dbg: - WHEN hdeps_get d x dbg ~> t THEN (data t) = pdeps_get d x. -Proof. - unfold hdeps_get, pdeps_get; destruct (Dict.get d x); wlp_simplify. -Qed. -Global Opaque hdeps_get. -Hint Resolve hdeps_get_correct: wlp. - -Definition hdeps_valid ge (hd:hdeps) m := forall ht, List.In ht hd.(hpre) -> tree_eval ge (data ht) m <> None. - - -Definition deps_model ge (d: deps) (hd:hdeps): Prop := - (forall m, hdeps_valid ge hd m <-> valid ge d m) - /\ (forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m = (deps_eval ge d x m)). - -Lemma deps_model_valid_alt ge d hd: deps_model ge d hd -> - forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m <> None. -Proof. - intros (H1 & H2) m x H. rewrite H2; auto. - unfold valid in H. intuition eauto. -Qed. - -Lemma deps_model_hdeps_valid_alt ge d hd: deps_model ge d hd -> - forall m x, hdeps_valid ge hd m -> tree_eval ge (pdeps_get hd x) m <> None. -Proof. - intros (H1 & H2) m x H. eapply deps_model_valid_alt. - - split; eauto. - - rewrite <- H1; auto. -Qed. - -Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree := - match e with - | PReg x => hdeps_get d x dbg - | Op o le => - DO lt <~ hlist_exp_tree le d od;; - hTop o lt dbg - | Old e => hexp_tree e od od dbg - end -with hlist_exp_tree (le: list_exp) (d od: hdeps): ?? hashV list_tree := - match le with - | Enil => hTnil tt - | Econs e le' => - DO t <~ hexp_tree e d od None;; - DO lt <~ hlist_exp_tree le' d od;; - hTcons t lt - | LOld le => hlist_exp_tree le od od - end. - -Lemma hexp_tree_correct_x ge e hod od: - deps_model ge od hod -> - forall hd d dbg, - deps_model ge d hd -> - WHEN hexp_tree e hd hod dbg ~> t THEN forall m, valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. -Proof. - intro H. - induction e using exp_mut with (P0:=fun le => forall d hd, - deps_model ge d hd -> - WHEN hlist_exp_tree le hd hod ~> lt THEN forall m, valid ge d m -> valid ge od m -> list_tree_eval ge (data lt) m = list_tree_eval ge (list_exp_tree le d od) m); - unfold deps_model, deps_eval in * |- * ; simpl; wlp_simplify. - - rewrite H1, H4; auto. - - rewrite H4, <- H0; simpl; auto. - - rewrite H1; simpl; auto. - - rewrite H5, <- H0, <- H4; simpl; auto. -Qed. -Global Opaque hexp_tree. - -Lemma hexp_tree_correct e hd hod dbg: - WHEN hexp_tree e hd hod dbg ~> t THEN forall ge od d m, deps_model ge od hod -> deps_model ge d hd -> valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m. -Proof. - unfold wlp; intros; eapply hexp_tree_correct_x; eauto. -Qed. -Hint Resolve hexp_tree_correct: wlp. - -Definition failsafe (t: tree): bool := - match t with - | Tname x => true - | Top o Tnil => is_constant o - | _ => false - end. - -Local Hint Resolve is_constant_correct. - -Lemma failsafe_correct ge (t: tree) m: failsafe t = true -> tree_eval ge t m <> None. -Proof. - destruct t; simpl; try congruence. - destruct l; simpl; try congruence. - eauto. -Qed. -Local Hint Resolve failsafe_correct. - -Definition naive_set (hd:hdeps) x (t:hashV tree) := - {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. - -Lemma naive_set_correct hd x ht ge d t: - deps_model ge d hd -> - (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) -> - deps_model ge (deps_set d x t) (naive_set hd x ht). -Proof. - unfold naive_set; intros (DM0 & DM1) EQT; split. - - intros m. - destruct (DM0 m) as (PRE & VALID0); clear DM0. - assert (VALID1: hdeps_valid ge hd m -> pre d ge m). { unfold valid in PRE; tauto. } - assert (VALID2: hdeps_valid ge hd m -> forall x : Dict.R.t, deps_eval ge d x m <> None). { unfold valid in PRE; tauto. } - unfold hdeps_valid in * |- *; simpl. - intuition (subst; eauto). - + eapply valid_set_proof; eauto. - erewrite <- EQT; eauto. - + exploit valid_set_decompose_1; eauto. - intros X1; exploit valid_set_decompose_2; eauto. - rewrite <- EQT; eauto. - + exploit valid_set_decompose_1; eauto. - - clear DM0. unfold deps_eval, pdeps_get, deps_get in * |- *; simpl. - Local Hint Resolve valid_set_decompose_1. - intros; case (R.eq_dec x x0). - + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. - + intros; rewrite !Dict.set_spec_diff; simpl; eauto. -Qed. -Local Hint Resolve naive_set_correct. - -Definition equiv_hdeps ge (hd1 hd2: hdeps) := - (forall m, hdeps_valid ge hd1 m <-> hdeps_valid ge hd2 m) - /\ (forall m x, hdeps_valid ge hd1 m -> tree_eval ge (pdeps_get hd1 x) m = tree_eval ge (pdeps_get hd2 x) m). - -Lemma equiv_deps_symmetry ge hd1 hd2: - equiv_hdeps ge hd1 hd2 -> equiv_hdeps ge hd2 hd1. -Proof. - intros (V1 & P1); split. - - intros; symmetry; auto. - - intros; symmetry; eapply P1. rewrite V1; auto. -Qed. - -Lemma equiv_hdeps_models ge hd1 hd2 d: - deps_model ge d hd1 -> equiv_hdeps ge hd1 hd2 -> deps_model ge d hd2. -Proof. - intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. - - intros m; rewrite <- VALID; auto. symmetry; auto. - - intros m x H. rewrite <- EQUIV; auto. - rewrite PEQUIV; auto. - rewrite VALID; auto. -Qed. - -Definition hdeps_set (hd:hdeps) x (t:hashV tree) := - DO ot <~ hdeps_get hd x None;; - DO b <~ phys_eq ot t;; - if b then - RET hd - else - RET {| hpre:= if failsafe (data t) then hd.(hpre) else t::hd.(hpre); - hpost:=Dict.set hd x t |}. - -Lemma hdeps_set_correct hd x ht: - WHEN hdeps_set hd x ht ~> nhd THEN - forall ge d t, deps_model ge d hd -> - (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) -> - deps_model ge (deps_set d x t) nhd. -Proof. - intros; wlp_simplify; eapply equiv_hdeps_models; eauto; unfold equiv_hdeps, hdeps_valid; simpl. - + split; eauto. - * intros m; split. - - intros X1 ht0 X2; apply X1; auto. - - intros X1 ht0 [Y1 | Y1]. subst. - rewrite H; eapply deps_model_hdeps_valid_alt; eauto. - eauto. - * intros m x0 X1. case (R.eq_dec x x0). - - intros; subst. unfold pdeps_get at 1. rewrite Dict.set_spec_eq. congruence. - - intros; unfold pdeps_get; rewrite Dict.set_spec_diff; auto. - + split; eauto. intros m. - generalize (failsafe_correct ge (data ht) m); intros FAILSAFE. - destruct (failsafe _); simpl; intuition (subst; eauto). -Qed. -Local Hint Resolve hdeps_set_correct: wlp. -Global Opaque hdeps_set. - -Variable debug_assign: R.t -> ?? option pstring. - -Fixpoint hinst_deps (i: inst) (d od: hdeps): ?? hdeps := - match i with - | nil => RET d - | (x, e)::i' => - DO dbg <~ debug_assign x;; - DO ht <~ hexp_tree e d od dbg;; - DO nd <~ hdeps_set d x ht;; - hinst_deps i' nd od - end. - - -Lemma hinst_deps_correct i: forall hd hod, - WHEN hinst_deps i hd hod ~> hd' THEN - forall ge od d, deps_model ge od hod -> deps_model ge d hd -> (forall m, valid ge d m -> valid ge od m) -> deps_model ge (inst_deps i d od) hd'. -Proof. - Local Hint Resolve valid_set_proof. - induction i; simpl; wlp_simplify; eauto 20. -Qed. -Global Opaque hinst_deps. -Local Hint Resolve hinst_deps_correct: wlp. - -(* logging info: we log the number of inst-instructions passed ! *) -Variable log: unit -> ?? unit. - -Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps := - match p with - | nil => RET d - | i::p' => - log tt;; - DO d' <~ hinst_deps i d d;; - hbblock_deps_rec p' d' - end. - -Lemma hbblock_deps_rec_correct p: forall hd, - WHEN hbblock_deps_rec p hd ~> hd' THEN forall ge d, deps_model ge d hd -> deps_model ge (bblock_deps_rec p d) hd'. -Proof. - induction p; simpl; wlp_simplify. -Qed. -Global Opaque hbblock_deps_rec. -Local Hint Resolve hbblock_deps_rec_correct: wlp. - - -Definition hbblock_deps: bblock -> ?? hdeps - := fun p => hbblock_deps_rec p {| hpre:= nil ; hpost := Dict.empty |}. - -Lemma hbblock_deps_correct p: - WHEN hbblock_deps p ~> hd THEN forall ge, deps_model ge (bblock_deps p) hd. -Proof. - unfold bblock_deps; wlp_simplify. eapply H. clear H. - unfold deps_model, valid, pdeps_get, hdeps_valid, deps_eval, deps_get; simpl; intuition; - rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. -Qed. -Global Opaque hbblock_deps. - -End CanonBuilding. - -(* Now, we build the hash-Cons value from a "hash_eq". - -Informal specification: - [hash_eq] must be consistent with the "hashed" constructors defined above. - -We expect that pre_hashV values in the code of these "hashed" constructors verify: - - (hash_eq (pre_data x) (pre_data y) ~> true) <-> (hcodes x)=(hcodes y) - -*) - -Definition tree_hash_eq (ta tb: tree): ?? bool := - match ta, tb with - | Tname xa, Tname xb => - if R.eq_dec xa xb (* Inefficient in some cases ? *) - then RET true - else RET false - | Top oa lta, Top ob ltb => - DO b <~ op_eq oa ob ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Local Hint Resolve op_eq_correct: wlp. - -Lemma tree_hash_eq_correct: forall ta tb, WHEN tree_hash_eq ta tb ~> b THEN b=true -> ta=tb. -Proof. - destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque tree_hash_eq. -Hint Resolve tree_hash_eq_correct: wlp. - -Definition list_tree_hash_eq (lta ltb: list_tree): ?? bool := - match lta, ltb with - | Tnil, Tnil => RET true - | Tcons ta lta, Tcons tb ltb => - DO b <~ phys_eq ta tb ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Lemma list_tree_hash_eq_correct: forall lta ltb, WHEN list_tree_hash_eq lta ltb ~> b THEN b=true -> lta=ltb. -Proof. - destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque list_tree_hash_eq. -Hint Resolve list_tree_hash_eq_correct: wlp. - -Lemma pdeps_get_intro (d1 d2: hdeps): - (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall x, pdeps_get d1 x = pdeps_get d2 x). -Proof. - unfold pdeps_get; intros H x; rewrite H. destruct (Dict.get d2 x); auto. -Qed. - -Local Hint Resolve hbblock_deps_correct Dict.eq_test_correct: wlp. - -(* TODO: - A REVOIR pour que Dict.test_eq qui soit insensible aux infos de debug ! - (cf. definition ci-dessous). - Il faut pour généraliser hash_params sur des Setoid (et les Dict aussi, avec ListSetoid, etc)... - *) -Program Definition mk_hash_params (log: hashV tree -> ?? unit): Dict.hash_params (hashV tree) := - {| (* Dict.test_eq := fun (ht1 ht2: hashV tree) => phys_eq (data ht1) (data ht2); *) - Dict.test_eq := phys_eq; - Dict.hashing := fun (ht: hashV tree) => RET (hid ht); - Dict.log := log |}. -Obligation 1. - eauto with wlp. -Qed. - -(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) - -Section Prog_Eq_Gen. - -Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 insts *) -Variable dbg2: R.t -> ?? option pstring. (* log of p2 insts *) -Variable log1: unit -> ?? unit. (* log of p1 insts *) -Variable log2: unit -> ?? unit. (* log of p2 insts *) - -Variable hco_tree: hashConsing tree. -Hypothesis hco_tree_correct: hCons_spec hco_tree. -Variable hco_list: hashConsing list_tree. -Hypothesis hco_list_correct: hCons_spec hco_list. - -Variable print_error_end: hdeps -> hdeps -> ?? unit. -Variable print_error: pstring -> ?? unit. - -Variable check_failpreserv: bool. -Variable dbg_failpreserv: hashV tree -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) - -Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := - DO failure_in_failpreserv <~ make_cref false;; - DO r <~ (TRY - DO d1 <~ hbblock_deps (hC hco_tree) (hC hco_list) dbg1 log1 p1 ;; - DO d2 <~ hbblock_deps (hC_known hco_tree) (hC_known hco_list) dbg2 log2 p2 ;; - DO b <~ Dict.eq_test d1 d2 ;; - if b then ( - if check_failpreserv then ( - let hp := mk_hash_params dbg_failpreserv in - failure_in_failpreserv.(set)(true);; - Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; - RET true - ) else RET false - ) else ( - print_error_end d1 d2 ;; - RET false - ) - CATCH_FAIL s, _ => - DO b <~ failure_in_failpreserv.(get)();; - if b then RET false - else print_error s;; RET false - ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; - RET (`r). -Obligation 1. - destruct hco_tree_correct as [TEQ1 TEQ2], hco_list_correct as [LEQ1 LEQ2]. - constructor 1; wlp_simplify; try congruence. - destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. - apply bblock_deps_simu; auto. - + intros m; rewrite <- EQPRE1, <- EQPRE2. - unfold incl, hdeps_valid in * |- *; intuition eauto. - + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. - erewrite pdeps_get_intro; auto. - auto. - erewrite <- EQPRE2; auto. - erewrite <- EQPRE1 in VALID. - unfold incl, hdeps_valid in * |- *; intuition eauto. -Qed. - -Theorem g_bblock_simu_test_correct p1 p2: - WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. - destruct exta0; simpl in * |- *; auto. -Qed. -Global Opaque g_bblock_simu_test. - -End Prog_Eq_Gen. - - - -Definition skip (_:unit): ?? unit := RET tt. -Definition no_dbg (_:R.t): ?? option pstring := RET None. - - -Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". -Definition msg_error_on_end: pstring := "mismatch in final assignments !". -Definition msg_unknow_tree: pstring := "unknown tree node". -Definition msg_unknow_list_tree: pstring := "unknown list node". -Definition msg_number: pstring := "on 2nd bblock -- on inst num ". -Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock". - -Definition print_error_end (_ _: hdeps): ?? unit - := println (msg_prefix +; msg_error_on_end). - -Definition print_error (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - println (msg_prefix +; msg_number +; n +; " -- " +; s). - -Definition failpreserv_error (_: hashV tree): ?? unit - := println (msg_prefix +; msg_notfailpreserv). - -Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := - DO log <~ count_logger ();; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (fun _ => RET msg_unknow_tree));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (fun _ => RET msg_unknow_list_tree));; - g_bblock_simu_test - no_dbg - no_dbg - skip - (log_insert log) - hco_tree _ - hco_list _ - print_error_end - (print_error log) - true (* check_failpreserv *) - failpreserv_error - p1 p2. -Obligation 1. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. - -Local Hint Resolve g_bblock_simu_test_correct. - -Theorem bblock_simu_test_correct p1 p2: - WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque bblock_simu_test. - - - -(** This is only to print info on each bblock_simu_test run **) -Section Verbose_version. - -Variable string_of_name: R.t -> ?? pstring. -Variable string_of_op: op -> ?? pstring. - -Definition tree_id (id: caml_string): pstring := "E" +; (CamlStr id). -Definition list_id (id: caml_string): pstring := "L" +; (CamlStr id). - -Local Open Scope string_scope. - -Definition print_raw_htree (td: pre_hashV tree): ?? unit := - match pre_data td, hcodes td with - | (Tname x), _ => - DO s <~ string_of_name x;; - println( "init_access " +; s) - | (Top o Tnil), _ => - DO so <~ string_of_op o;; - println so - | (Top o _), [ _; _; lid ] => - DO so <~ string_of_op o;; - DO sl <~ string_of_hashcode lid;; - println (so +; " " +; (list_id sl)) - | _, _ => FAILWITH "unexpected hcodes" - end. - -Definition print_raw_hlist(ld: pre_hashV list_tree): ?? unit := - match pre_data ld, hcodes ld with - | Tnil, _ => println "" - | (Tcons _ _), [ t ; l ] => - DO st <~ string_of_hashcode t ;; - DO sl <~ string_of_hashcode l ;; - println((tree_id st) +; " " +; (list_id sl)) - | _, _ => FAILWITH "unexpected hcodes" - end. - -Section PrettryPrint. - -Variable get_htree: hashcode -> ?? pre_hashV tree. -Variable get_hlist: hashcode -> ?? pre_hashV list_tree. - -(* NB: requires [t = pre_data pt] *) -Fixpoint string_of_tree (t: tree) (pt: pre_hashV tree) : ?? pstring := - match debug_info pt with - | Some x => RET x - | None => - match t, hcodes pt with - | Tname x, _ => string_of_name x - | Top o Tnil, _ => string_of_op o - | Top o (_ as l), [ _; _; lid ] => - DO so <~ string_of_op o;; - DO pl <~ get_hlist lid;; - DO sl <~ string_of_list_tree l pl;; - RET (so +; "(" +; sl +; ")") - | _, _ => FAILWITH "unexpected hcodes" - end - end -(* NB: requires [l = pre_data pl] *) -with string_of_list_tree (l: list_tree) (lt: pre_hashV list_tree): ?? pstring := - match l, hcodes lt with - | Tnil, _ => RET (Str "") - | Tcons t Tnil, [ tid ; l ] => - DO pt <~ get_htree tid;; - string_of_tree t pt - | Tcons t l', [ tid ; lid' ] => - DO pt <~ get_htree tid;; - DO st <~ string_of_tree t pt;; - DO pl' <~ get_hlist lid';; - DO sl <~ string_of_list_tree l' pl';; - RET (st +; "," +; sl) - | _, _ => FAILWITH "unexpected hcodes" - end. - - -End PrettryPrint. - - -Definition pretty_tree ext exl pt := - DO r <~ string_of_tree (get_hashV ext) (get_hashV exl) (pre_data pt) pt;; - println(r). - -Fixpoint print_head (head: list pstring): ?? unit := - match head with - | i::head' => println ("--- inst " +; i);; print_head head' - | _ => RET tt - end. - -Definition print_htree ext exl (head: list pstring) (hid: hashcode) (td: pre_hashV tree): ?? unit := - print_head head;; - DO s <~ string_of_hashcode hid ;; - print ((tree_id s) +; ": ");; - print_raw_htree td;; - match debug_info td with - | Some x => - print("// " +; x +; " <- ");; - pretty_tree ext exl {| pre_data:=(pre_data td); hcodes:=(hcodes td); debug_info:=None |} - | None => RET tt - end. - -Definition print_hlist (head: list pstring) (hid: hashcode) (ld: pre_hashV list_tree): ?? unit := - print_head head;; - DO s <~ string_of_hashcode hid ;; - print ((list_id s) +; ": ");; - print_raw_hlist ld. - -Definition print_tables ext exl: ?? unit := - println "-- tree table --" ;; - iterall ext (print_htree ext exl);; - println "-- list table --" ;; - iterall exl print_hlist;; - println "----------------". - -Definition print_final_debug ext exl (d1 d2: hdeps): ?? unit - := DO b <~ Dict.not_eq_witness d1 d2 ;; - match b with - | Some x => - DO s <~ string_of_name x;; - println("mismatch on: " +; s);; - match Dict.get d1 x with - | None => println("=> unassigned in 1st bblock") - | Some ht1 => - print("=> node expected from 1st bblock: ");; - DO pt1 <~ get_hashV ext (hid ht1);; - pretty_tree ext exl pt1 - end;; - match Dict.get d2 x with - | None => println("=> unassigned in 2nd bblock") - | Some ht2 => - print("=> node found from 2nd bblock: ");; - DO pt2 <~ get_hashV ext (hid ht2);; - pretty_tree ext exl pt2 - end - | None => FAILWITH "bug in Dict.not_eq_witness ?" - end. - -Inductive witness:= - | Htree (pt: pre_hashV tree) - | Hlist (pl: pre_hashV list_tree) - | Nothing - . - -Definition msg_tree (cr: cref witness) td := - set cr (Htree td);; - RET msg_unknow_tree. - -Definition msg_list (cr: cref witness) tl := - set cr (Hlist tl);; - RET msg_unknow_list_tree. - -Definition print_witness ext exl cr msg := - DO wit <~ get cr ();; - match wit with - | Htree pt => - println("=> unknown tree node: ");; - pretty_tree ext exl {| pre_data:=(pre_data pt); hcodes:=(hcodes pt); debug_info:=None |};; - println("=> encoded on " +; msg +; " graph as: ");; - print_raw_htree pt - | Hlist pl => - println("=> unknown list node: ");; - DO r <~ string_of_list_tree (get_hashV ext) (get_hashV exl) (pre_data pl) pl;; - println(r);; - println("=> encoded on " +; msg +; " graph as: ");; - print_raw_hlist pl - | _ => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" - end. - - -Definition print_error_end1 hct hcl (d1 d2:hdeps): ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl;; - print_error_end d1 d2;; - print_final_debug ext exl d1 d2. - -Definition print_error1 hct hcl cr log s : ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl;; - print_error log s;; - print_witness ext exl cr "1st". - - -Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". - -Definition print_error_end2 hct hcl (d1 d2:hdeps): ?? unit - := println (msg_prefix +; msg_error_on_end);; - println "- GRAPH of 2nd bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables ext exl. - -Definition print_error2 hct hcl cr (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; - print_witness ext exl cr "2nd";; - println "- GRAPH of 2nd bblock";; - print_tables ext exl. - -Definition simple_debug (x: R.t): ?? option pstring := - DO s <~ string_of_name x;; - RET (Some s). - -Definition log_debug (log: logger unit) (x: R.t): ?? option pstring := - DO i <~ log_info log ();; - DO sx <~ string_of_name x;; - RET (Some (sx +; "@" +; i)). - -Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing list_tree): unit -> ?? unit := - (fun _ => - log_insert log tt ;; - DO s <~ log_info log tt;; - next_log hct s;; - next_log hcl s - ). - -Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref Nothing;; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));; - DO result1 <~ g_bblock_simu_test - (log_debug log1) - simple_debug - (hlog log1 hco_tree hco_list) - (log_insert log2) - hco_tree _ - hco_list _ - (print_error_end1 hco_tree hco_list) - (print_error1 hco_tree hco_list cr log2) - true - failpreserv_error (* TODO: debug info *) - p1 p2;; - if result1 - then RET true - else - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref Nothing;; - DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));; - DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));; - DO result2 <~ g_bblock_simu_test - (log_debug log1) - simple_debug - (hlog log1 hco_tree hco_list) - (log_insert log2) - hco_tree _ - hco_list _ - (print_error_end2 hco_tree hco_list) - (print_error2 hco_tree hco_list cr log2) - false - (fun _ => RET tt) - p2 p1;; - if result2 - then ( - println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; - RET false - ) else RET false - . -Obligation 1. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. -Obligation 3. - generalize (hCons_correct _ _ _ _ H0); clear H0. - constructor 1; wlp_simplify. -Qed. -Obligation 4. - generalize (hCons_correct _ _ _ _ H); clear H. - constructor 1; wlp_simplify. -Qed. - -Theorem verb_bblock_simu_test_correct p1 p2: - WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque verb_bblock_simu_test. - -End Verbose_version. - - -End ImpDepTree. - -Require Import FMapPositive. - -Module ImpPosDict <: ImpDict with Module R:=Pos. - -Include PosDict. -Import PositiveMap. - -Fixpoint eq_test {A} (d1 d2: t A): ?? bool := - match d1, d2 with - | Leaf _, Leaf _ => RET true - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - else - RET false - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - | _, _ => RET false - end. - -Lemma eq_test_correct A d1: forall (d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. -Proof. - unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; - wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). -Qed. -Global Opaque eq_test. - -(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) -Fixpoint pick {A} (d: t A): ?? R.t := - match d with - | Leaf _ => FAILWITH "unexpected empty dictionary" - | Node _ (Some _) _ => RET xH - | Node (Leaf _) None r => - DO p <~ pick r;; - RET (xI p) - | Node l None _ => - DO p <~ pick l;; - RET (xO p) - end. - -(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) -Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := - match d1, d2 with - | Leaf _, Leaf _ => RET None - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - else - RET (Some xH) - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - | l, Leaf _ => DO p <~ pick l;; RET (Some p) - | Leaf _, r => DO p <~ pick r;; RET (Some p) - | _, _ => RET (Some xH) - end. - -End ImpPosDict. - diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v new file mode 100644 index 00000000..8c9c820f --- /dev/null +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -0,0 +1,1108 @@ +(** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks + +with imperative hash-consing, and rewriting. + +*) + +Require Export Impure.ImpHCons. +Export Notations. +Import HConsing. + + +Require Export SeqSimuTheory. + +Require Import PArith. + + +Local Open Scope impure. + +Import ListNotations. +Local Open Scope list_scope. + + +Module Type ImpParam. + +Include LangParam. + +Parameter op_eq: op -> op -> ?? bool. + +Parameter op_eq_correct: forall o1 o2, + WHEN op_eq o1 o2 ~> b THEN + b=true -> o1 = o2. + +End ImpParam. + + +Module Type ISeqLanguage. + +Declare Module LP: ImpParam. + +Include MkSeqLanguage LP. + +End ISeqLanguage. + + +Module Type ImpDict. + +Include PseudoRegDictionary. + +Parameter eq_test: forall {A}, t A -> t A -> ?? bool. + +Parameter eq_test_correct: forall A (d1 d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. + +(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) + + +(* only for debugging *) +Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. + +End ImpDict. + + +Module Type ImpSimuInterface. + +Declare Module CoreL: ISeqLanguage. +Import CoreL. +Import Terms. + +Parameter bblock_simu_test: (forall t : term, reduction t) -> bblock -> bblock -> ?? bool. + +Parameter bblock_simu_test_correct: forall (reduce: forall t, reduction t) (p1 p2 : bblock), + WHEN bblock_simu_test reduce p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + + +Parameter verb_bblock_simu_test + : (forall t : term, reduction t) -> + (R.t -> ?? pstring) -> + (op -> ?? pstring) -> bblock -> bblock -> ?? bool. + +Parameter verb_bblock_simu_test_correct: + forall (reduce: forall t, reduction t) + (string_of_name : R.t -> ?? pstring) + (string_of_op : op -> ?? pstring) + (p1 p2 : bblock), + WHEN verb_bblock_simu_test reduce string_of_name string_of_op p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + +End ImpSimuInterface. + + + +Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuInterface with Module CoreL := L. + +Module CoreL:=L. + +Module ST := SimuTheory L Dict. + +Import ST. + +Definition term_set_hid (t: term) (hid: hashcode): term := + match t with + | Input x _ => Input x hid + | App op l _ => App op l hid + end. + +Definition list_term_set_hid (l: list_term) (hid: hashcode): list_term := + match l with + | LTnil _ => LTnil hid + | LTcons t l' _ => LTcons t l' hid + end. + +Lemma term_eval_set_hid ge t hid m: + term_eval ge (term_set_hid t hid) m = term_eval ge t m. +Proof. + destruct t; simpl; auto. +Qed. + +Lemma list_term_eval_set_hid ge l hid m: + list_term_eval ge (list_term_set_hid l hid) m = list_term_eval ge l m. +Proof. + destruct l; simpl; auto. +Qed. + +(* Local nickname *) +Module D:=ImpPrelude.Dict. + +Section SimuWithReduce. + +Variable reduce: forall t, reduction t. + +Section CanonBuilding. + +Variable hC_term: hashinfo term -> ?? term. +Hypothesis hC_term_correct: forall t, WHEN hC_term t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hC_list_term: hashinfo list_term -> ?? list_term. +Hypothesis hC_list_term_correct: forall t, WHEN hC_list_term t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +(* First, we wrap constructors for hashed values !*) + +Local Open Scope positive. +Local Open Scope list_scope. + +Definition hInput_hcodes (x:R.t) := + DO hc <~ hash 1;; + DO hv <~ hash x;; + RET [hc;hv]. +Extraction Inline hInput_hcodes. + +Definition hInput (x:R.t): ?? term := + DO hv <~ hInput_hcodes x;; + hC_term {| hdata:=Input x unknown_hid; hcodes :=hv; |}. + +Lemma hInput_correct x: + WHEN hInput x ~> t THEN forall ge m, term_eval ge t m = Some (m x). +Proof. + wlp_simplify. +Qed. +Global Opaque hInput. +Hint Resolve hInput_correct: wlp. + +Definition hApp_hcodes (o:op) (l: list_term) := + DO hc <~ hash 2;; + DO hv <~ hash o;; + RET [hc;hv;list_term_get_hid l]. +Extraction Inline hApp_hcodes. + +Definition hApp (o:op) (l: list_term) : ?? term := + DO hv <~ hApp_hcodes o l;; + hC_term {| hdata:=App o l unknown_hid; hcodes:=hv |}. + +Lemma hApp_correct o l: + WHEN hApp o l ~> t THEN forall ge m, + term_eval ge t m = match list_term_eval ge l m with + | Some v => op_eval ge o v + | None => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hApp. +Hint Resolve hApp_correct: wlp. + +Definition hLTnil (_: unit): ?? list_term := + hC_list_term {| hdata:=LTnil unknown_hid; hcodes := nil; |} . + +Lemma hLTnil_correct x: + WHEN hLTnil x ~> l THEN forall ge m, list_term_eval ge l m = Some nil. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTnil. +Hint Resolve hLTnil_correct: wlp. + + +Definition hLTcons (t: term) (l: list_term): ?? list_term := + hC_list_term {| hdata:=LTcons t l unknown_hid; hcodes := [term_get_hid t; list_term_get_hid l]; |}. + +Lemma hLTcons_correct t l: + WHEN hLTcons t l ~> l' THEN forall ge m, + list_term_eval ge l' m = match term_eval ge t m, list_term_eval ge l m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTcons. +Hint Resolve hLTcons_correct: wlp. + +(* Second, we use these hashed constructors ! *) + +Record hsmem:= {hpre: list term; hpost: Dict.t term}. + +Coercion hpost: hsmem >-> Dict.t. + +Definition hsmem_get (d:hsmem) x: ?? term := + match Dict.get d x with + | None => hInput x + | Some t => RET t + end. + +Lemma hsmem_get_correct (d:hsmem) x: + WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = smem_eval ge d x m. +Proof. + unfold hsmem_get, smem_eval, smem_get; destruct (Dict.get d x); wlp_simplify. +Qed. +Global Opaque hsmem_get. +Hint Resolve hsmem_get_correct: wlp. + +Definition smem_model ge (d: smem) (hd:hsmem): Prop := + (forall m, allvalid ge hd.(hpre) m <-> svalid ge d m) + /\ (forall m x, svalid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). + +Lemma smem_model_svalid_alt ge d hd: smem_model ge d hd -> + forall m x, svalid ge d m -> smem_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. rewrite H2; auto. + unfold svalid in H. intuition eauto. +Qed. + +Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> + forall m x, allvalid ge hd.(hpre) m -> smem_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. eapply smem_model_svalid_alt. + - split; eauto. + - rewrite <- H1; auto. +Qed. + +Definition naive_set (hd:hsmem) x (t:term) := + {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. + +Lemma naive_set_correct hd x ht ge d t: + smem_model ge d hd -> + (forall m, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + smem_model ge (smem_set d x t) (naive_set hd x ht). +Proof. + unfold naive_set; intros (DM0 & DM1) EQT; split. + - intros m. + destruct (DM0 m) as (PRE & VALID0); clear DM0. + assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold svalid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold svalid in PRE; tauto. } + unfold allvalid in * |- *; simpl. + intuition (subst; eauto). + + eapply svalid_set_proof; eauto. + erewrite <- EQT; eauto. + + exploit svalid_set_decompose_1; eauto. + intros X1; exploit svalid_set_decompose_2; eauto. + rewrite <- EQT; eauto. + + exploit svalid_set_decompose_1; eauto. + - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. + Local Hint Resolve svalid_set_decompose_1. + intros; case (R.eq_dec x x0). + + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + + intros; rewrite !Dict.set_spec_diff; simpl; eauto. +Qed. +Local Hint Resolve naive_set_correct. + +Definition equiv_hsmem ge (hd1 hd2: hsmem) := + (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) + /\ (forall m x, allvalid ge hd1.(hpre) m -> smem_eval ge hd1 x m = smem_eval ge hd2 x m). + +Lemma equiv_smem_symmetry ge hd1 hd2: + equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1. +Proof. + intros (V1 & P1); split. + - intros; symmetry; auto. + - intros; symmetry; eapply P1. rewrite V1; auto. +Qed. + +Lemma equiv_hsmem_models ge hd1 hd2 d: + smem_model ge d hd1 -> equiv_hsmem ge hd1 hd2 -> smem_model ge d hd2. +Proof. + intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. + - intros m; rewrite <- VALID; auto. symmetry; auto. + - intros m x H. rewrite <- EQUIV; auto. + rewrite PEQUIV; auto. + rewrite VALID; auto. +Qed. + +Variable log_assign: R.t -> term -> ?? unit. + +Definition lift {A B} hid (x:A) (k: B -> ?? A) (y:B): ?? A := + DO b <~ phys_eq hid unknown_hid;; + if b then k y else RET x. + +Fixpoint hterm_lift (t: term): ?? term := + match t with + | Input x hid => lift hid t hInput x + | App o l hid => + lift hid t + (fun l => DO lt <~ hlist_term_lift l;; + hApp o lt) l + end +with hlist_term_lift (l: list_term) {struct l}: ?? list_term := + match l with + | LTnil hid => lift hid l hLTnil () + | LTcons t l' hid => + lift hid l + (fun t => DO t <~ hterm_lift t;; + DO lt <~ hlist_term_lift l';; + hLTcons t lt) t + end. + +Lemma hterm_lift_correct t: + WHEN hterm_lift t ~> ht THEN forall ge m, term_eval ge ht m = term_eval ge t m. +Proof. + induction t using term_mut with (P0:=fun lt => + WHEN hlist_term_lift lt ~> hlt THEN forall ge m, list_term_eval ge hlt m = list_term_eval ge lt m); + wlp_simplify. + - rewrite H0, H; auto. + - rewrite H1, H0, H; auto. +Qed. +Local Hint Resolve hterm_lift_correct: wlp. +Global Opaque hterm_lift. + +Variable log_new_hterm: term -> ?? unit. + +Fixpoint hterm_append (l: list term) (lh: list term): ?? list term := + match l with + | nil => RET lh + | t::l' => + DO ht <~ hterm_lift t;; + log_new_hterm ht;; + hterm_append l' (ht::lh) + end. + +Lemma hterm_append_correct l: forall lh, + WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)). +Proof. + Local Hint Resolve eq_trans: localhint. + unfold allvalid; induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). + intros REC ge m; rewrite REC; clear IHl' REC. intuition (subst; eauto with wlp localhint). +Qed. +(*Local Hint Resolve hterm_append_correct: wlp.*) +Global Opaque hterm_append. + +Definition smart_set (hd:hsmem) x (ht:term) := + match ht with + | Input _ _ => + DO ot <~ hsmem_get hd x;; + DO b <~ phys_eq ot ht;; + if b then + RET (hd.(hpost)) + else ( + log_assign x ht;; + RET (Dict.set hd x ht) + ) + | _ => + log_assign x ht;; + RET (Dict.set hd x ht) + end. + +Lemma smart_set_correct hd x ht: + WHEN smart_set hd x ht ~> d THEN + forall ge m y, smem_eval ge d y m = smem_eval ge (Dict.set hd x ht) y m. +Proof. + destruct ht; wlp_simplify. + unfold smem_eval at 2; unfold smem_get; simpl; case (R.eq_dec x y). + - intros; subst. rewrite Dict.set_spec_eq. congruence. + - intros; rewrite Dict.set_spec_diff; auto. +Qed. +(*Local Hint Resolve smart_set_correct: wlp.*) +Global Opaque smart_set. + +Definition hsmem_set (hd:hsmem) x (t:term) := + DO pt <~ reduce t;; + DO lht <~ hterm_append pt.(valid) hd.(hpre);; + DO ht <~ hterm_lift pt.(effect);; + log_new_hterm ht;; + DO nd <~ smart_set hd x ht;; + RET {| hpre := lht; hpost := nd |}. + +Lemma hsmem_set_correct hd x ht: + WHEN hsmem_set hd x ht ~> nhd THEN + forall ge d t, smem_model ge d hd -> + (forall m, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + smem_model ge (smem_set d x t) nhd. +Proof. + intros; wlp_simplify. + generalize (hterm_append_correct _ _ _ Hexta0); intro APPEND. + generalize (hterm_lift_correct _ _ Hexta1); intro LIFT. + generalize (smart_set_correct _ _ _ _ Hexta3); intro SMART. + eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. + destruct H as (VALID & EFFECT); split. + - intros; rewrite APPEND, <- VALID. + unfold allvalid; simpl; intuition (subst; eauto). + - intros m x0 ALLVALID; rewrite SMART. + destruct (term_eval ge ht m) eqn: Hht. + * case (R.eq_dec x x0). + + intros; subst. unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. + erewrite LIFT, EFFECT; eauto. + + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. + * destruct (ALLVALID ht); simpl; auto. +Qed. +Local Hint Resolve hsmem_set_correct: wlp. +Global Opaque hsmem_set. + +Lemma exp_hterm_correct ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + forall m, svalid ge d m -> svalid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. +Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> forall m, svalid ge d m -> svalid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); + unfold smem_model in * |- * ; simpl; intuition eauto. + - erewrite IHe; eauto. + - erewrite IHe0, IHe; eauto. +Qed. +Local Hint Resolve exp_hterm_correct: wlp. + +Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := + match i with + | nil => RET hd + | (x, e)::i' => + DO nd <~ hsmem_set hd x (exp_term e hd hod);; + hinst_smem i' nd hod + end. + +Lemma hinst_smem_correct i: forall hd hod, + WHEN hinst_smem i hd hod ~> hd' THEN + forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, svalid ge d m -> svalid ge od m) -> smem_model ge (inst_smem i d od) hd'. +Proof. + Local Hint Resolve svalid_set_proof. + induction i; simpl; wlp_simplify; eauto 15 with wlp. +Qed. +Global Opaque hinst_smem. +Local Hint Resolve hinst_smem_correct: wlp. + +(* logging info: we log the number of inst-instructions passed ! *) +Variable log_new_inst: unit -> ?? unit. + +Fixpoint hbblock_smem_rec (p: bblock) (d: hsmem): ?? hsmem := + match p with + | nil => RET d + | i::p' => + log_new_inst tt;; + DO d' <~ hinst_smem i d d;; + hbblock_smem_rec p' d' + end. + +Lemma hbblock_smem_rec_correct p: forall hd, + WHEN hbblock_smem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. +Proof. + induction p; simpl; wlp_simplify. +Qed. +Global Opaque hbblock_smem_rec. +Local Hint Resolve hbblock_smem_rec_correct: wlp. + + +Definition hbblock_smem: bblock -> ?? hsmem + := fun p => hbblock_smem_rec p {| hpre:= nil ; hpost := Dict.empty |}. + +Lemma hbblock_smem_correct p: + WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Proof. + unfold bblock_smem; wlp_simplify. eapply H. clear H. + unfold smem_model, svalid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. +Qed. +Global Opaque hbblock_smem. + +End CanonBuilding. + +(* Now, we build the hash-Cons value from a "hash_eq". + +Informal specification: + [hash_eq] must be consistent with the "hashed" constructors defined above. + +We expect that hashinfo values in the code of these "hashed" constructors verify: + + (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) + +*) + +Definition term_hash_eq (ta tb: term): ?? bool := + match ta, tb with + | Input xa _, Input xb _ => + if R.eq_dec xa xb (* Inefficient in some cases ? *) + then RET true + else RET false + | App oa lta _, App ob ltb _ => + DO b <~ op_eq oa ob ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma term_hash_eq_correct: forall ta tb, WHEN term_hash_eq ta tb ~> b THEN b=true -> term_set_hid ta unknown_hid=term_set_hid tb unknown_hid. +Proof. + Local Hint Resolve op_eq_correct: wlp. + destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque term_hash_eq. +Hint Resolve term_hash_eq_correct: wlp. + +Definition list_term_hash_eq (lta ltb: list_term): ?? bool := + match lta, ltb with + | LTnil _, LTnil _ => RET true + | LTcons ta lta _, LTcons tb ltb _ => + DO b <~ phys_eq ta tb ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma list_term_hash_eq_correct: forall lta ltb, WHEN list_term_hash_eq lta ltb ~> b THEN b=true -> list_term_set_hid lta unknown_hid=list_term_set_hid ltb unknown_hid. +Proof. + destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque list_term_hash_eq. +Hint Resolve list_term_hash_eq_correct: wlp. + +Lemma smem_eval_intro (d1 d2: hsmem): + (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, smem_eval ge d1 x m = smem_eval ge d2 x m). +Proof. + unfold smem_eval, smem_get; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. +Qed. + +Local Hint Resolve hbblock_smem_correct Dict.eq_test_correct: wlp. + +Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := + {| + Dict.test_eq := phys_eq; + Dict.hashing := fun (ht: term) => RET (term_get_hid ht); + Dict.log := log |}. +Obligation 1. + eauto with wlp. +Qed. + +(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) +Definition no_log_assign (x:R.t) (t:term): ?? unit := RET tt. +Definition no_log_new_term (t:term): ?? unit := RET tt. + +Section Prog_Eq_Gen. + +Variable log_assign: R.t -> term -> ?? unit. +Variable log_new_term: hashConsing term -> hashConsing list_term -> ??(term -> ?? unit). +Variable log_inst1: unit -> ?? unit. (* log of p1 insts *) +Variable log_inst2: unit -> ?? unit. (* log of p2 insts *) + +Variable hco_term: hashConsing term. +Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hco_list: hashConsing list_term. +Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +Variable print_error_end: hsmem -> hsmem -> ?? unit. +Variable print_error: pstring -> ?? unit. + +Variable check_failpreserv: bool. +Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) + +Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := + DO failure_in_failpreserv <~ make_cref false;; + DO r <~ (TRY + DO d1 <~ hbblock_smem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; + DO log_new_term <~ log_new_term hco_term hco_list;; + DO d2 <~ hbblock_smem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; + DO b <~ Dict.eq_test d1 d2 ;; + if b then ( + if check_failpreserv then ( + let hp := mk_hash_params dbg_failpreserv in + failure_in_failpreserv.(set)(true);; + Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; + RET true + ) else RET false + ) else ( + print_error_end d1 d2 ;; + RET false + ) + CATCH_FAIL s, _ => + DO b <~ failure_in_failpreserv.(get)();; + if b then RET false + else print_error s;; RET false + ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; + RET (`r). +Obligation 1. + constructor 1; wlp_simplify; try congruence. + destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. + apply bblock_smem_simu; auto. + + intros m; rewrite <- EQPRE1, <- EQPRE2. + unfold incl, allvalid in * |- *; intuition eauto. + + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. + erewrite smem_eval_intro; eauto. + erewrite <- EQPRE2; auto. + erewrite <- EQPRE1 in VALID. + unfold incl, allvalid in * |- *; intuition eauto. +Qed. + +Theorem g_bblock_simu_test_correct p1 p2: + WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. + destruct exta0; simpl in * |- *; auto. +Qed. +Global Opaque g_bblock_simu_test. + +End Prog_Eq_Gen. + + + +Definition hht: hashH term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. +Definition hlht: hashH list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. + +Definition recover_hcodes (t:term): ??(hashinfo term) := + match t with + | Input x _ => + DO hv <~ hInput_hcodes x ;; + RET {| hdata := t; hcodes := hv |} + | App o l _ => + DO hv <~ hApp_hcodes o l ;; + RET {| hdata := t; hcodes := hv |} + end. + + +Definition msg_end_of_bblock: pstring :="--- unknown subterms in the graph". + +Definition log_new_term + (unknownHash_msg: term -> ?? pstring) + (hct:hashConsing term) + (hcl:hashConsing list_term) + : ?? (term -> ?? unit) := + DO clock <~ hct.(next_hid)();; + hct.(next_log) msg_end_of_bblock;; + hcl.(next_log) msg_end_of_bblock;; + RET (fun t => + DO ok <~ hash_older (term_get_hid t) clock;; + if ok + then + RET tt + else + DO ht <~ recover_hcodes t;; + hct.(remove) ht;; + DO msg <~ unknownHash_msg t;; + FAILWITH msg). + +Definition skip (_:unit): ?? unit := RET tt. + +Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". +Definition msg_error_on_end: pstring := "mismatch in final assignments !". +Definition msg_unknow_term: pstring := "unknown term". +Definition msg_number: pstring := "on 2nd bblock -- on inst num ". +Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)". + +Definition print_error_end (_ _: hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end). + +Definition print_error (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + println (msg_prefix +; msg_number +; n +; " -- " +; s). + +Definition failpreserv_error (_: term): ?? unit + := println (msg_prefix +; msg_notfailpreserv). + +Lemma term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + term_set_hid t1 hid1 = term_set_hid t2 hid2 -> term_eval ge t1 m = term_eval ge t2 m. +Proof. + intro H; erewrite <- term_eval_set_hid; rewrite H. apply term_eval_set_hid. +Qed. + +Lemma list_term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + list_term_set_hid t1 hid1 = list_term_set_hid t2 hid2 -> list_term_eval ge t1 m = list_term_eval ge t2 m. +Proof. + intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. +Qed. + +Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv. + +Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := + DO log <~ count_logger ();; + DO hco_term <~ mk_annot (hCons hht);; + DO hco_list <~ mk_annot (hCons hlht);; + g_bblock_simu_test + no_log_assign + (log_new_term (fun _ => RET msg_unknow_term)) + skip + (log_insert log) + hco_term _ + hco_list _ + print_error_end + (print_error log) + true (* check_failpreserv *) + failpreserv_error + p1 p2. +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Local Hint Resolve g_bblock_simu_test_correct. + +Theorem bblock_simu_test_correct p1 p2: + WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque bblock_simu_test. + +(** This is only to print info on each bblock_simu_test run **) +Section Verbose_version. + +Variable string_of_name: R.t -> ?? pstring. +Variable string_of_op: op -> ?? pstring. + + +Local Open Scope string_scope. + +Definition string_term_hid (t: term): ?? pstring := + DO id <~ string_of_hashcode (term_get_hid t);; + RET ("E" +; (CamlStr id)). + +Definition string_list_hid (lt: list_term): ?? pstring := + DO id <~ string_of_hashcode (list_term_get_hid lt);; + RET ("L" +; (CamlStr id)). + +Definition print_raw_term (t: term): ?? unit := + match t with + | Input x _ => + DO s <~ string_of_name x;; + println( "init_access " +; s) + | App o (LTnil _) _ => + DO so <~ string_of_op o;; + println so + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_list_hid l;; + println (so +; " " +; sl) + end. + +(* +Definition print_raw_list(lt: list_term): ?? unit := + match lt with + | LTnil _=> println "" + | LTcons t l _ => + DO st <~ string_term_hid t;; + DO sl <~ string_list_hid l;; + println(st +; " " +; sl) + end. +*) + +Section PrettryPrint. + +Variable get_debug_info: term -> ?? option pstring. + +Fixpoint string_of_term (t: term): ?? pstring := + match t with + | Input x _ => string_of_name x + | App o (LTnil _) _ => string_of_op o + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_of_list_term l;; + RET (so +; "[" +; sl +; "]") + end +with string_of_list_term (l: list_term): ?? pstring := + match l with + | LTnil _ => RET (Str "") + | LTcons t (LTnil _) _ => + DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end + | LTcons t l' _ => + DO st <~ (DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end);; + DO sl <~ string_of_list_term l';; + RET (st +; ";" +; sl) + end. + + +End PrettryPrint. + + +Definition pretty_term gdi t := + DO r <~ string_of_term gdi t;; + println(r). + +Fixpoint print_head (head: list pstring): ?? unit := + match head with + | i::head' => println (i);; print_head head' + | _ => RET tt + end. + +Definition print_term gdi (head: list pstring) (t: term): ?? unit := + print_head head;; + DO s <~ string_term_hid t;; + print (s +; ": ");; + print_raw_term t;; + DO dbg <~ gdi t;; + match dbg with + | Some x => + print("// " +; x +; " <- ");; + pretty_term gdi t + | None => RET tt + end. + +Definition print_list gdi (head: list pstring) (lt: list_term): ?? unit := + print_head head;; + DO s <~ string_list_hid lt ;; + print (s +; ": ");; + (* print_raw_list lt;; *) + DO ps <~ string_of_list_term gdi lt;; + println("[" +; ps +; "]"). + + +Definition print_tables gdi ext exl: ?? unit := + println "-- term table --" ;; + iterall ext (fun head _ pt => print_term gdi head pt.(hdata));; + println "-- list table --" ;; + iterall exl (fun head _ pl => print_list gdi head pl.(hdata));; + println "----------------". + +Definition print_final_debug gdi (d1 d2: hsmem): ?? unit + := DO b <~ Dict.not_eq_witness d1 d2 ;; + match b with + | Some x => + DO s <~ string_of_name x;; + println("mismatch on: " +; s);; + match Dict.get d1 x with + | None => println("=> unassigned in 1st bblock") + | Some t1 => + print("=> node expected from 1st bblock: ");; + pretty_term gdi t1 + end;; + match Dict.get d2 x with + | None => println("=> unassigned in 2nd bblock") + | Some t2 => + print("=> node found from 2nd bblock: ");; + pretty_term gdi t2 + end + | None => FAILWITH "bug in Dict.not_eq_witness ?" + end. + +Definition witness:= option term. + +Definition msg_term (cr: cref witness) t := + set cr (Some t);; + RET msg_unknow_term. + +Definition print_witness gdi cr (*msg*) := + DO wit <~ get cr ();; + match wit with + | Some t => + println("=> unknown term node: ");; + pretty_term gdi t (*;; + println("=> encoded on " +; msg +; " graph as: ");; + print_raw_term t *) + | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" + end. + + +Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error_end d1 d2;; + print_final_debug gdi d1 d2. + +Definition print_error1 gdi hct hcl cr log s : ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error log s;; + print_witness gdi cr (*"1st"*). + + +Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". + +Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end);; + println "- GRAPH of 2nd bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl. + +Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; + print_witness gdi cr (*"2nd"*);; + println "- GRAPH of 2nd bblock";; + print_tables gdi ext exl. + +(* USELESS +Definition simple_log_assign (d: D.t term pstring) (x: R.t) (t: term): ?? unit := + DO s <~ string_of_name x;; + d.(D.set) (t,s). +*) + +Definition log_assign (d: D.t term pstring) (log: logger unit) (x: R.t) (t: term): ?? unit := + DO i <~ log_info log ();; + DO sx <~ string_of_name x;; + d.(D.set) (t,(sx +; "@" +; i)). + +Definition msg_new_inst : pstring := "--- inst ". + +Definition hlog (log: logger unit) (hct: hashConsing term) (hcl: hashConsing list_term): unit -> ?? unit := + (fun _ => + log_insert log tt ;; + DO s <~ log_info log tt;; + let s:= msg_new_inst +; s in + next_log hct s;; + next_log hcl s + ). + +Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hht);; + DO hco_list <~ mk_annot (hCons hlht);; + DO result1 <~ g_bblock_simu_test + (log_assign dict_info log1) + (log_new_term (msg_term cr)) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end1 dict_info.(D.get) hco_term hco_list) + (print_error1 dict_info.(D.get) hco_term hco_list cr log2) + true + failpreserv_error + p1 p2;; + if result1 + then RET true + else + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hht);; + DO hco_list <~ mk_annot (hCons hlht);; + DO result2 <~ g_bblock_simu_test + (log_assign dict_info log1) + (log_new_term (msg_term cr)) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end2 dict_info.(D.get) hco_term hco_list) + (print_error2 dict_info.(D.get) hco_term hco_list cr log2) + false + (fun _ => RET tt) + p2 p1;; + if result2 + then ( + println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; + RET false + ) else RET false + . +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. +Obligation 3. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 4. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Theorem verb_bblock_simu_test_correct p1 p2: + WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque verb_bblock_simu_test. + +End Verbose_version. + +End SimuWithReduce. + +(* TODO: why inlining fails here ? *) +Transparent hterm_lift. +Extraction Inline lift. + +End ImpSimu. + +Require Import FMapPositive. + +Module ImpPosDict <: ImpDict with Module R:=Pos. + +Include PosDict. +Import PositiveMap. + +Fixpoint eq_test {A} (d1 d2: t A): ?? bool := + match d1, d2 with + | Leaf _, Leaf _ => RET true + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + else + RET false + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + | _, _ => RET false + end. + +Lemma eq_test_correct A d1: forall (d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. +Proof. + unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; + wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). +Qed. +Global Opaque eq_test. + +(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) +Fixpoint pick {A} (d: t A): ?? R.t := + match d with + | Leaf _ => FAILWITH "unexpected empty dictionary" + | Node _ (Some _) _ => RET xH + | Node (Leaf _) None r => + DO p <~ pick r;; + RET (xI p) + | Node l None _ => + DO p <~ pick l;; + RET (xO p) + end. + +(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) +Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := + match d1, d2 with + | Leaf _, Leaf _ => RET None + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + else + RET (Some xH) + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + | l, Leaf _ => DO p <~ pick l;; RET (Some p) + | Leaf _, r => DO p <~ pick r;; RET (Some p) + | _, _ => RET (Some xH) + end. + +End ImpPosDict. + diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index 7925f62d..f1abaf7a 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -193,4 +193,4 @@ Ltac wlp_xsimplify hint := Create HintDb wlp discriminated. -Ltac wlp_simplify := wlp_xsimplify ltac:(intuition (eauto with wlp)). \ No newline at end of file +Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). \ No newline at end of file diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index dd615628..637e8296 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -99,41 +99,101 @@ Hint Resolve assert_list_incl_correct. End Sets. + + + (********************************) (* (Weak) HConsing *) +Module HConsing. -Axiom xhCons: forall {A}, ((A -> A -> ?? bool) * (pre_hashV A -> ?? hashV A)) -> ?? hashConsing A. +Export HConsingDefs. + +(* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) +Axiom xhCons: forall {A}, (hashH A) -> ?? hashConsing A. Extract Constant xhCons => "ImpHConsOracles.xhCons". -Definition hCons_eq_msg: pstring := "xhCons: hash_eq differs". +Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". -Definition hCons {A} (hash_eq: A -> A -> ?? bool) (unknownHash_msg: pre_hashV A -> ?? pstring): ?? (hashConsing A) := - DO hco <~ xhCons (hash_eq, fun v => DO s <~ unknownHash_msg v ;; FAILWITH s) ;; +Definition hCons {A} (hh: hashH A): ?? (hashConsing A) := + DO hco <~ xhCons hh ;; RET {| - hC := fun x => - DO x' <~ hC hco x ;; - DO b0 <~ hash_eq (pre_data x) (data x') ;; - assert_b b0 hCons_eq_msg;; - RET x'; - hC_known := fun x => - DO x' <~ hC_known hco x ;; - DO b0 <~ hash_eq (pre_data x) (data x') ;; - assert_b b0 hCons_eq_msg;; - RET x'; - next_log := next_log hco; - export := export hco; + hC := (fun x => + DO x' <~ hC hco x ;; + DO b0 <~ hash_eq hh x.(hdata) x' ;; + assert_b b0 hCons_eq_msg;; + RET x'); + next_hid := hco.(next_hid); + next_log := hco.(next_log); + export := hco.(export); + remove := hco.(remove) |}. -Lemma hCons_correct: forall A (hash_eq: A -> A -> ?? bool) msg, - WHEN hCons hash_eq msg ~> hco THEN - ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x')) - /\ ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')). + +Lemma hCons_correct A (hh: hashH A): + WHEN hCons hh ~> hco THEN + (forall x y, WHEN hh.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hh x)=(ignore_hid hh y)) -> + forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hh x.(hdata)=ignore_hid hh x'. Proof. wlp_simplify. Qed. Global Opaque hCons. Hint Resolve hCons_correct: wlp. -Definition hCons_spec {A} (hco: hashConsing A) := - (forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x')) /\ (forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')). + + +(* hashV: extending a given type with hash-consing *) +Record hashV {A:Type}:= { + data: A; + hid: hashcode +}. +Arguments hashV: clear implicits. + +Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashH (hashV A) := {| + hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data); + get_hid := hid; + set_hid := fun v id => {| data := v.(data); hid := id |} +|}. + +Definition liftHV (x:nat) := {| data := x; hid := unknown_hid |}. + +Definition hConsV {A} (hasheq: A -> A -> ?? bool): ?? (hashConsing (hashV A)) := + hCons (hashV_C hasheq). + +Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): + WHEN hConsV hasheq ~> hco THEN + (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> + forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). +Proof. + Local Hint Resolve f_equal2. + wlp_simplify. + exploit H; eauto. + + wlp_simplify. + + intros; congruence. +Qed. +Global Opaque hConsV. +Hint Resolve hConsV_correct: wlp. + +Definition hC_known {A} (hco:hashConsing (hashV A)) (unknownHash_msg: hashinfo (hashV A) -> ?? pstring) (x:hashinfo (hashV A)): ?? hashV A := + DO clock <~ hco.(next_hid)();; + DO x' <~ hco.(hC) x;; + DO ok <~ hash_older x'.(hid) clock;; + if ok + then RET x' + else + hco.(remove) x;; + DO msg <~ unknownHash_msg x;; + FAILWITH msg. + +Lemma hC_known_correct A (hco:hashConsing (hashV A)) msg x: + WHEN hC_known hco msg x ~> x' THEN + (forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data)) -> + x.(hdata).(data)=x'.(data). +Proof. + wlp_simplify. + unfold wlp in * |- ; eauto. +Qed. +Global Opaque hC_known. +Hint Resolve hC_known_correct: wlp. + +End HConsing. diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v index dc8b2627..33376c19 100644 --- a/mppa_k1c/abstractbb/Impure/ImpLoops.v +++ b/mppa_k1c/abstractbb/Impure/ImpLoops.v @@ -17,7 +17,7 @@ Section While_Loop. (** Local Definition of "while-loop-invariant" *) Let wli {S} cond body (I: S -> Prop) := forall s, I s -> cond s = true -> WHEN (body s) ~> s' THEN I s'. -Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | I s0 -> I s /\ cond s = false} +Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | (I s0 -> I s) /\ cond s = false} := loop (A:={s | I s0 -> I s}) (s0, fun s => @@ -26,7 +26,7 @@ Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? { DO s' <~ mk_annot (body s) ;; RET (inl (A:={s | I s0 -> I s }) s') | false => - RET (inr (B:={s | I s0 -> I s /\ cond s = false}) s) + RET (inr (B:={s | (I s0 -> I s) /\ cond s = false}) s) end). Obligation 2. unfold wli, wlp in * |-; eauto. @@ -83,7 +83,7 @@ Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ?? assert_b b msg;; RET (output a). -Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool)x (k: A -> ?? answ R): +Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool) (k: A -> ?? answ R) x: beq_correct beq -> WHEN wapply beq k x ~> y THEN R x y. Proof. @@ -107,7 +107,7 @@ Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop Program Definition rec {A B} beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): ?? (A -> ?? B) := DO f <~ xrec (B:=answ R) (fun f x => DO y <~ mk_annot (recF (wapply beq f) x) ;; - RET {| input := x; output := proj1_sig y |});; + RET {| input := x; output := `y |});; RET (wapply beq f). Obligation 1. eapply H1; eauto. clear H H1. diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 1a84eb3b..477be65c 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -91,11 +91,17 @@ Extract Inlined Constant struct_eq => "(=)". Hint Resolve struct_eq_correct: wlp. -(** Data-structure for generic hash-consing, hash-set *) +(** Data-structure for generic hash-consing *) Axiom hashcode: Type. Extract Constant hashcode => "int". +(* NB: hashConsing is assumed to generate hash-code in ascending order. + This gives a way to check that a hash-consed value is older than an other one. +*) +Axiom hash_older: hashcode -> hashcode -> ?? bool. +Extract Inlined Constant hash_older => "(<)". + Module Dict. Record hash_params {A:Type} := { @@ -115,42 +121,45 @@ Arguments t: clear implicits. End Dict. +Module HConsingDefs. -(* NB: hashConsing is assumed to generate hash-code in ascending order. - This gives a way to check that a hash-consed value is older than an other one. -*) -Axiom hash_older: hashcode -> hashcode -> ?? bool. -Extract Inlined Constant hash_older => "(<=)". - -Record pre_hashV {A: Type} := { - pre_data: A; +Record hashinfo {A: Type} := { + hdata: A; hcodes: list hashcode; - debug_info: option pstring; }. -Arguments pre_hashV: clear implicits. +Arguments hashinfo: clear implicits. -Record hashV {A:Type}:= { - data: A; - hid: hashcode +(* for inductive types with intrinsic hash-consing *) +Record hashH {A:Type}:= { + hash_eq: A -> A -> ?? bool; + get_hid: A -> hashcode; + set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *) }. -Arguments hashV: clear implicits. +Arguments hashH: clear implicits. + +Axiom unknown_hid: hashcode. +Extract Constant unknown_hid => "-1". + +Definition ignore_hid {A} (hh: hashH A) (hv:A) := set_hid hh hv unknown_hid. Record hashExport {A:Type}:= { - get_hashV: hashcode -> ?? pre_hashV A; - iterall: ((list pstring) -> hashcode -> pre_hashV A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) + get_info: hashcode -> ?? hashinfo A; + iterall: ((list pstring) -> hashcode -> hashinfo A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) }. Arguments hashExport: clear implicits. Record hashConsing {A:Type}:= { - (* TODO next_hashcode: unit -> ?? hashcode *) - hC: pre_hashV A -> ?? hashV A; - hC_known: pre_hashV A -> ?? hashV A; (* fails on unknown inputs *) - (**** below: debugging functions ****) + hC: hashinfo A -> ?? A; + (**** below: debugging or internal functions ****) + next_hid: unit -> ?? hashcode; (* should be strictly less old than ignore_hid *) + remove: hashinfo A -> ??unit; (* SHOULD NOT BE USED ! *) next_log: pstring -> ?? unit; (* insert a log info (for the next introduced element) -- regiven by [iterall export] below *) export: unit -> ?? hashExport A ; }. Arguments hashConsing: clear implicits. +End HConsingDefs. + (** recMode: this is mainly for Tests ! *) Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec. diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml index b7a80679..3994cae6 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -1,6 +1,5 @@ open ImpPrelude - -exception Stop;; +open HConsingDefs let make_dict (type key) (p: key Dict.hash_params) = let module MyHashedType = struct @@ -16,10 +15,15 @@ let make_dict (type key) (p: key Dict.hash_params) = } -let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) = +exception Stop;; + +let xhCons (type a) (hh:a hashH) = + (* We use a hash-table, but a hash-set would be sufficient ! *) + (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *) + (* Ideally, a parameter would allow to select between the weak or full version *) let module MyHashedType = struct - type t = a pre_hashV - let equal x y = hash_eq x.pre_data y.pre_data + type t = a hashinfo + let equal x y = hh.hash_eq x.hdata y.hdata let hash x = Hashtbl.hash x.hcodes end in let module MyHashtbl = Hashtbl.Make(MyHashedType) in @@ -34,21 +38,18 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) let t = MyHashtbl.create 1000 in let logs = ref [] in { - hC = (fun (x:a pre_hashV) -> - match MyHashtbl.find_opt t x with - | Some x' -> x' + hC = (fun (k:a hashinfo) -> + match MyHashtbl.find_opt t k with + | Some d -> d | None -> (*print_string "+";*) - let x' = { data = x.pre_data ; - hid = MyHashtbl.length t } - in MyHashtbl.add t x x'; x'); - hC_known = (fun (x:a pre_hashV) -> - match MyHashtbl.find_opt t x with - | Some x' -> x' - | None -> error x); + let d = hh.set_hid k.hdata (MyHashtbl.length t) in + MyHashtbl.add t {k with hdata = d } d; d); next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); + next_hid = (fun () -> MyHashtbl.length t); + remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x); export = fun () -> match pick t with - | None -> { get_hashV = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } + | None -> { get_info = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } | Some (k,_) -> (* the state is fully copied at export ! *) let logs = ref (List.rev_append (!logs) []) in @@ -57,9 +58,9 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) | (j, info)::l' when i>=j -> logs:=l'; info::(step_log i) | _ -> [] in let a = Array.make (MyHashtbl.length t) k in - MyHashtbl.iter (fun k d -> a.(d.hid) <- k) t; + MyHashtbl.iter (fun k d -> a.(hh.get_hid d) <- k) t; { - get_hashV = (fun i -> a.(i)); + get_info = (fun i -> a.(i)); iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a) } } diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli index a74c721a..9f5eca89 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -1,4 +1,5 @@ open ImpPrelude +open HConsingDefs -val make_dict : 'a1 Dict.hash_params -> ('a1, 'a2) Dict.t -val xhCons: (('a -> 'a -> bool) * ('a pre_hashV -> 'a hashV)) -> 'a hashConsing +val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t +val xhCons: 'a hashH -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index d1971e57..22809095 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -1,4 +1,4 @@ -(** Parallel Semantics of Abstract Basic Blocks and parallelizability test.s +(** Parallel Semantics of Abstract Basic Blocks and parallelizability test. *) Require Setoid. (* in order to rewrite <-> *) @@ -32,7 +32,7 @@ Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem := end end. -(* [inst_prun] is generalization of [inst_run] *) +(* [inst_prun] is generalization of [inst_run] *) Lemma inst_run_prun i: forall m old, inst_run ge i m old = inst_prun i m m old. Proof. diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v new file mode 100644 index 00000000..45afd830 --- /dev/null +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -0,0 +1,428 @@ +(** A theory for checking/proving simulation by symbolic execution. + +*) + + +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. +Require Import List. +Require Import ImpPrelude. +Import HConsingDefs. + +Module Type PseudoRegDictionary. + +Declare Module R: PseudoRegisters. + +Parameter t: Type -> Type. + +Parameter get: forall {A}, t A -> R.t -> option A. + +Parameter set: forall {A}, t A -> R.t -> A -> t A. + +Parameter set_spec_eq: forall A d x (v: A), + get (set d x v) x = Some v. + +Parameter set_spec_diff: forall A d x y (v: A), + x <> y -> get (set d x v) y = get d y. + +Parameter empty: forall {A}, t A. + +Parameter empty_spec: forall A x, + get (empty (A:=A)) x = None. + +End PseudoRegDictionary. + + +Module SimuTheory (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). + +Export L. +Export LP. +Export Terms. + +(* the symbolic memory: + - pre: pre-condition expressing that the computation has not yet abort on a None. + - post: the post-condition for each pseudo-register +*) +Record smem:= {pre: genv -> mem -> Prop; post: Dict.t term}. + +Coercion post: smem >-> Dict.t. + +(** initial symbolic memory *) +Definition smem_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. + +Definition smem_get (d:Dict.t term) x := + match Dict.get d x with + | None => Input x unknown_hid + | Some t => t + end. + +Fixpoint exp_term (e: exp) (d old: Dict.t term): term := + match e with + | PReg x => smem_get d x + | Op o le => App o (list_exp_term le d old) unknown_hid + | Old e => exp_term e old old + end +with list_exp_term (le: list_exp) (d old: Dict.t term) : list_term := + match le with + | Enil => LTnil unknown_hid + | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) unknown_hid + | LOld le => list_exp_term le old old + end. + +(** evaluation of the post-condition *) +Definition smem_eval ge (d: Dict.t term) x (m:mem) := + term_eval ge (smem_get d x) m. + +(** assignment of the symbolic memory *) +Definition smem_set (d:smem) x (t:term) := + {| pre:=(fun ge m => (smem_eval ge d x m) <> None /\ (d.(pre) ge m)); + post:=Dict.set d x t |}. + +Section SIMU_THEORY. + +Variable ge: genv. + +Lemma set_spec_eq d x t m: + smem_eval ge (smem_set d x t) x m = term_eval ge t m. +Proof. + unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. +Qed. + +Lemma set_spec_diff d x y t m: + x <> y -> smem_eval ge (smem_set d x t) y m = smem_eval ge d y m. +Proof. + intros; unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. +Qed. + +Lemma smem_eval_empty x m: smem_eval ge smem_empty x m = Some (m x). +Proof. + unfold smem_eval, smem_get; rewrite Dict.empty_spec; simpl; auto. +Qed. + +Hint Rewrite set_spec_eq smem_eval_empty: dict_rw. + +Fixpoint inst_smem (i: inst) (d old: smem): smem := + match i with + | nil => d + | (x, e)::i' => + let t:=exp_term e d old in + inst_smem i' (smem_set d x t) old + end. + +Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := + match p with + | nil => d + | i::p' => + let d':=inst_smem i d d in + bblock_smem_rec p' d' + end. + +Local Hint Resolve smem_eval_empty. + +Definition bblock_smem: bblock -> smem + := fun p => bblock_smem_rec p smem_empty. + +Lemma inst_smem_pre_monotonic i old: forall d m, + (pre (inst_smem i d old) ge m) -> (pre d ge m). +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d a H; generalize (IHi _ _ H); clear H IHi. + unfold smem_set; simpl; intuition. +Qed. + +Lemma bblock_smem_pre_monotonic p: forall d m, + (pre (bblock_smem_rec p d) ge m) -> (pre d ge m). +Proof. + induction p as [|i p' IHp']; simpl; eauto. + intros d a H; eapply inst_smem_pre_monotonic; eauto. +Qed. + +Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic. + +Lemma term_eval_exp e (od:smem) m0 old: + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall d m1, + (forall x, smem_eval ge (d:smem) x m0 = Some (m1 x)) -> + term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. +Proof. + unfold smem_eval in * |- *; intro H. + induction e using exp_mut with + (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (smem_get d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); + simpl; auto. + - intros; erewrite IHe; eauto. + - intros. erewrite IHe, IHe0; eauto. +Qed. + +Lemma inst_smem_abort i m0 x old: forall d, + pre (inst_smem i d old) ge m0 -> + smem_eval ge d x m0 = None -> + smem_eval ge (inst_smem i d old) x m0 = None. +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d VALID H; erewrite IHi; eauto. clear IHi. + destruct (R.eq_dec x y). + * subst; autorewrite with dict_rw. + generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold smem_set; simpl; intuition congruence. + * rewrite set_spec_diff; auto. +Qed. + +Lemma block_smem_rec_abort p m0 x: forall d, + pre (bblock_smem_rec p d) ge m0 -> + smem_eval ge d x m0 = None -> + smem_eval ge (bblock_smem_rec p d) x m0 = None. +Proof. + induction p; simpl; auto. + intros d VALID H; erewrite IHp; eauto. clear IHp. + eapply inst_smem_abort; eauto. +Qed. + +Lemma inst_smem_Some_correct1 i m0 old (od:smem): + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + inst_run ge i m1 old = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x). +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. + refine (IHi _ _ _ _ _ _); eauto. + clear x0; intros x0. + unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. +Qed. + +Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), + run ge p m1 = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x). +Proof. + Local Hint Resolve inst_smem_Some_correct1. + induction p as [ | i p]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (inst_run ge i m1 m1) eqn: Heqov. + + refine (IHp _ _ _ _ _ _); eauto. + + inversion H. +Qed. + +Lemma bblock_smem_Some_correct1 p m0 m1: + run ge p m0 = Some m1 + -> forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x). +Proof. + intros; eapply bblocks_smem_rec_Some_correct1; eauto. +Qed. + +Lemma inst_smem_None_correct i m0 old (od: smem): + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall m1 d, pre (inst_smem i d od) ge m0 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + inst_run ge i m1 old = None -> exists x, smem_eval ge (inst_smem i d od) x m0 = None. +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. + - discriminate. + - intros VALID H0. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _); eauto. + intros x0; unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + intuition. + constructor 1 with (x:=x); simpl. + apply inst_smem_abort; auto. + autorewrite with dict_rw. + erewrite term_eval_exp; eauto. +Qed. + +Lemma inst_smem_Some_correct2 i m0 old (od: smem): + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall (m1 m2: mem) d, + pre (inst_smem i d od) ge m0 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x)) -> + res_eq (Some m2) (inst_run ge i m1 old). +Proof. + intro X. + induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _ _ _); eauto. + intros x0; unfold assign; destruct (R.eq_dec x x0). + * subst. autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. + + generalize (H x). + rewrite inst_smem_abort; discriminate || auto. + autorewrite with dict_rw. + erewrite term_eval_exp; eauto. +Qed. + +Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d, + pre (bblock_smem_rec p d) ge m0 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x)) -> + res_eq (Some m2) (run ge p m1). +Proof. + induction p as [|i p]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (inst_run ge i m1 m1) eqn: Heqom. + + refine (IHp _ _ _ _ _ _); eauto. + + assert (X: exists x, term_eval ge (smem_get (inst_smem i d d) x) m0 = None). + { eapply inst_smem_None_correct; eauto. } + destruct X as [x H1]. + generalize (H x). + erewrite block_smem_rec_abort; eauto. + congruence. +Qed. + + +Lemma bblock_smem_Some_correct2 p m0 m1: + pre (bblock_smem p) ge m0 -> + (forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x)) + -> res_eq (Some m1) (run ge p m0). +Proof. + intros; eapply bblocks_smem_rec_Some_correct2; eauto. +Qed. + +Lemma inst_valid i m0 old (od:smem): + (forall x, smem_eval ge od x m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + pre d ge m0 -> + inst_run ge i m1 old = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + pre (inst_smem i d od) ge m0. +Proof. + induction i as [|[x e] i IHi]; simpl; auto. + intros Hold m1 m2 d VALID0 H Hm1. + destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. + eapply IHi; eauto. + + unfold smem_set in * |- *; simpl. + rewrite Hm1; intuition congruence. + + intros x0. unfold assign; destruct (R.eq_dec x x0). + * subst; autorewrite with dict_rw. + erewrite term_eval_exp; eauto. + * rewrite set_spec_diff; auto. +Qed. + + +Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), + pre d ge m0 -> + run ge p m1 = Some m2 -> + (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + pre (bblock_smem_rec p d) ge m0. +Proof. + Local Hint Resolve inst_valid. + induction p as [ | i p]; simpl; intros m1 d H; auto. + intros H0 H1. + destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. + congruence. +Qed. + +Lemma bblock_smem_valid p m0 m1: + run ge p m0 = Some m1 -> + pre (bblock_smem p) ge m0. +Proof. + intros; eapply block_smem_rec_valid; eauto. + unfold smem_empty; simpl. auto. +Qed. + +Definition svalid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. + +Theorem bblock_smem_simu p1 p2: + (forall m, svalid ge (bblock_smem p1) m -> svalid ge (bblock_smem p2) m) -> + (forall m0 x m1, svalid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> + smem_eval ge (bblock_smem p2) x m0 = Some m1) -> + bblock_simu ge p1 p2. +Proof. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. + unfold svalid; intros INCL EQUIV m DONTFAIL. + destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. + assert (X: forall x, smem_eval ge (bblock_smem p1) x m = Some (m1 x)); eauto. + eapply bblock_smem_Some_correct2; eauto. + + destruct (INCL m); intuition eauto. + congruence. + + intro x; apply EQUIV; intuition eauto. + congruence. +Qed. + +Lemma svalid_set_decompose_1 d t x m: + svalid ge (smem_set d x t) m -> svalid ge d m. +Proof. + unfold svalid; intros ((PRE1 & PRE2) & VALID); split. + + intuition. + + intros x0 H. case (R.eq_dec x x0). + * intuition congruence. + * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. +Qed. + +Lemma svalid_set_decompose_2 d t x m: + svalid ge (smem_set d x t) m -> term_eval ge t m <> None. +Proof. + unfold svalid; intros ((PRE1 & PRE2) & VALID) H. + generalize (VALID x); autorewrite with dict_rw. + tauto. +Qed. + +Lemma svalid_set_proof d x t m: + svalid ge d m -> term_eval ge t m <> None -> svalid ge (smem_set d x t) m. +Proof. + unfold svalid; intros (PRE & VALID) PREt. split. + + split; auto. + + intros x0; case (R.eq_dec x x0). + - intros; subst; autorewrite with dict_rw. auto. + - intros. rewrite set_spec_diff; auto. +Qed. + +End SIMU_THEORY. + +End SimuTheory. + +Require Import PArith. +Require Import FMapPositive. + +Module PosDict <: PseudoRegDictionary with Module R:=Pos. + +Module R:=Pos. + +Definition t:=PositiveMap.t. + +Definition get {A} (d:t A) (x:R.t): option A + := PositiveMap.find x d. + +Definition set {A} (d:t A) (x:R.t) (v:A): t A + := PositiveMap.add x v d. + +Local Hint Unfold PositiveMap.E.eq. + +Lemma set_spec_eq A d x (v: A): + get (set d x v) x = Some v. +Proof. + unfold get, set; apply PositiveMap.add_1; auto. +Qed. + +Lemma set_spec_diff A d x y (v: A): + x <> y -> get (set d x v) y = get d y. +Proof. + unfold get, set; intros; apply PositiveMap.gso; auto. +Qed. + +Definition empty {A}: t A := PositiveMap.empty A. + +Lemma empty_spec A x: + get (empty (A:=A)) x = None. +Proof. + unfold get, empty; apply PositiveMap.gempty; auto. +Qed. + +End PosDict. \ No newline at end of file -- cgit From e9e83f59ed2b1087ea974e7112abf71d8eb4195b Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 26 May 2019 15:00:35 +0200 Subject: slightly more efficient version --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 10 ++-- mppa_k1c/abstractbb/ImpSimuTest.v | 89 +++++++++++++++++++++------- mppa_k1c/abstractbb/SeqSimuTheory.v | 26 ++++---- 3 files changed, 85 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index f381c810..8ee04f44 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -306,12 +306,12 @@ Definition list_term_get_hid (l: list_term): hashcode := Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. Record pseudo_term: Type := { - valid: list term; + mayfail: list term; effect: term }. Definition match_pseudo_term (t: term) (pt: pseudo_term) := - (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(valid) m) + (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). Import ImpCore.Notations. @@ -323,7 +323,7 @@ Record reduction (t:term):= { }. Hint Resolve result_correct: wlp. -Program Definition identity_reduce (t: term): reduction t := {| result := RET {| valid := [t]; effect := t |} |}. +Program Definition identity_reduce (t: term): reduction t := {| result := RET {| mayfail := [t]; effect := t |} |}. Obligation 1. unfold match_pseudo_term, allvalid; wlp_simplify; congruence. Qed. @@ -331,9 +331,9 @@ Global Opaque identity_reduce. Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := match t with - | Input x _ => {| result := RET {| valid := []; effect := t |} |} + | Input x _ => {| result := RET {| mayfail := []; effect := t |} |} | o @ [] => match is_constant o with - | true => {| result := RET {| valid := []; effect := t |} |} + | true => {| result := RET {| mayfail := []; effect := t |} |} | false => identity_reduce t end | _ => identity_reduce t diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 8c9c820f..13af4289 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -231,20 +231,20 @@ Global Opaque hsmem_get. Hint Resolve hsmem_get_correct: wlp. Definition smem_model ge (d: smem) (hd:hsmem): Prop := - (forall m, allvalid ge hd.(hpre) m <-> svalid ge d m) - /\ (forall m x, svalid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). + (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) + /\ (forall m x, smem_valid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). -Lemma smem_model_svalid_alt ge d hd: smem_model ge d hd -> - forall m x, svalid ge d m -> smem_eval ge hd x m <> None. +Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> + forall m x, smem_valid ge d m -> smem_eval ge hd x m <> None. Proof. intros (H1 & H2) m x H. rewrite H2; auto. - unfold svalid in H. intuition eauto. + unfold smem_valid in H. intuition eauto. Qed. Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> forall m x, allvalid ge hd.(hpre) m -> smem_eval ge hd x m <> None. Proof. - intros (H1 & H2) m x H. eapply smem_model_svalid_alt. + intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. - split; eauto. - rewrite <- H1; auto. Qed. @@ -254,24 +254,24 @@ Definition naive_set (hd:hsmem) x (t:term) := Lemma naive_set_correct hd x ht ge d t: smem_model ge d hd -> - (forall m, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = term_eval ge t m) -> smem_model ge (smem_set d x t) (naive_set hd x ht). Proof. unfold naive_set; intros (DM0 & DM1) EQT; split. - intros m. destruct (DM0 m) as (PRE & VALID0); clear DM0. - assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold svalid in PRE; tauto. } - assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold svalid in PRE; tauto. } + assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold smem_valid in PRE; tauto. } unfold allvalid in * |- *; simpl. intuition (subst; eauto). - + eapply svalid_set_proof; eauto. + + eapply smem_valid_set_proof; eauto. erewrite <- EQT; eauto. - + exploit svalid_set_decompose_1; eauto. - intros X1; exploit svalid_set_decompose_2; eauto. + + exploit smem_valid_set_decompose_1; eauto. + intros X1; exploit smem_valid_set_decompose_2; eauto. rewrite <- EQT; eauto. - + exploit svalid_set_decompose_1; eauto. + + exploit smem_valid_set_decompose_1; eauto. - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. - Local Hint Resolve svalid_set_decompose_1. + Local Hint Resolve smem_valid_set_decompose_1. intros; case (R.eq_dec x x0). + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + intros; rewrite !Dict.set_spec_diff; simpl; eauto. @@ -387,7 +387,7 @@ Global Opaque smart_set. Definition hsmem_set (hd:hsmem) x (t:term) := DO pt <~ reduce t;; - DO lht <~ hterm_append pt.(valid) hd.(hpre);; + DO lht <~ hterm_append pt.(mayfail) hd.(hpre);; DO ht <~ hterm_lift pt.(effect);; log_new_hterm ht;; DO nd <~ smart_set hd x ht;; @@ -396,7 +396,7 @@ Definition hsmem_set (hd:hsmem) x (t:term) := Lemma hsmem_set_correct hd x ht: WHEN hsmem_set hd x ht ~> nhd THEN forall ge d t, smem_model ge d hd -> - (forall m, svalid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = term_eval ge t m) -> smem_model ge (smem_set d x t) nhd. Proof. intros; wlp_simplify. @@ -418,34 +418,79 @@ Qed. Local Hint Resolve hsmem_set_correct: wlp. Global Opaque hsmem_set. +(* VARIANTE: we do not hash-cons the term from the expression Lemma exp_hterm_correct ge e hod od: smem_model ge od hod -> forall hd d, smem_model ge d hd -> - forall m, svalid ge d m -> svalid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. + forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. Proof. intro H. induction e using exp_mut with (P0:=fun le => forall d hd, - smem_model ge d hd -> forall m, svalid ge d m -> svalid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); + smem_model ge d hd -> forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); unfold smem_model in * |- * ; simpl; intuition eauto. - erewrite IHe; eauto. - erewrite IHe0, IHe; eauto. Qed. Local Hint Resolve exp_hterm_correct: wlp. +*) + +Fixpoint hexp_term (e: exp) (d od: hsmem): ?? term := + match e with + | PReg x => hsmem_get d x + | Op o le => + DO lt <~ hlist_exp_term le d od;; + hApp o lt + | Old e => hexp_term e od od + end +with hlist_exp_term (le: list_exp) (d od: hsmem): ?? list_term := + match le with + | Enil => hLTnil tt + | Econs e le' => + DO t <~ hexp_term e d od;; + DO lt <~ hlist_exp_term le' d od;; + hLTcons t lt + | LOld le => hlist_exp_term le od od + end. + +Lemma hexp_term_correct_x ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + WHEN hexp_term e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = term_eval ge (exp_term e d od) m. + Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> + WHEN hlist_exp_term le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = list_term_eval ge (list_exp_term le d od) m); + unfold smem_model, smem_eval in * |- * ; simpl; wlp_simplify. + - rewrite H1, <- H4; auto. + - rewrite H4, <- H0; simpl; auto. + - rewrite H5, <- H0, <- H4; simpl; auto. +Qed. +Global Opaque hexp_term. + +Lemma hexp_term_correct e hd hod: + WHEN hexp_term e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = term_eval ge (exp_term e d od) m. +Proof. + unfold wlp; intros; eapply hexp_term_correct_x; eauto. +Qed. +Hint Resolve hexp_term_correct: wlp. Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := match i with | nil => RET hd | (x, e)::i' => - DO nd <~ hsmem_set hd x (exp_term e hd hod);; + DO ht <~ hexp_term e hd hod;; + DO nd <~ hsmem_set hd x ht;; hinst_smem i' nd hod end. Lemma hinst_smem_correct i: forall hd hod, WHEN hinst_smem i hd hod ~> hd' THEN - forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, svalid ge d m -> svalid ge od m) -> smem_model ge (inst_smem i d od) hd'. + forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. Proof. - Local Hint Resolve svalid_set_proof. + Local Hint Resolve smem_valid_set_proof. induction i; simpl; wlp_simplify; eauto 15 with wlp. Qed. Global Opaque hinst_smem. @@ -479,7 +524,7 @@ Lemma hbblock_smem_correct p: WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, svalid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + unfold smem_model, smem_valid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. Qed. Global Opaque hbblock_smem. diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 45afd830..8b6a372a 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -337,16 +337,16 @@ Proof. unfold smem_empty; simpl. auto. Qed. -Definition svalid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. +Definition smem_valid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. Theorem bblock_smem_simu p1 p2: - (forall m, svalid ge (bblock_smem p1) m -> svalid ge (bblock_smem p2) m) -> - (forall m0 x m1, svalid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> + (forall m, smem_valid ge (bblock_smem p1) m -> smem_valid ge (bblock_smem p2) m) -> + (forall m0 x m1, smem_valid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> smem_eval ge (bblock_smem p2) x m0 = Some m1) -> bblock_simu ge p1 p2. Proof. Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. - unfold svalid; intros INCL EQUIV m DONTFAIL. + unfold smem_valid; intros INCL EQUIV m DONTFAIL. destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. assert (X: forall x, smem_eval ge (bblock_smem p1) x m = Some (m1 x)); eauto. eapply bblock_smem_Some_correct2; eauto. @@ -356,28 +356,28 @@ Proof. congruence. Qed. -Lemma svalid_set_decompose_1 d t x m: - svalid ge (smem_set d x t) m -> svalid ge d m. +Lemma smem_valid_set_decompose_1 d t x m: + smem_valid ge (smem_set d x t) m -> smem_valid ge d m. Proof. - unfold svalid; intros ((PRE1 & PRE2) & VALID); split. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID); split. + intuition. + intros x0 H. case (R.eq_dec x x0). * intuition congruence. * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. Qed. -Lemma svalid_set_decompose_2 d t x m: - svalid ge (smem_set d x t) m -> term_eval ge t m <> None. +Lemma smem_valid_set_decompose_2 d t x m: + smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None. Proof. - unfold svalid; intros ((PRE1 & PRE2) & VALID) H. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. generalize (VALID x); autorewrite with dict_rw. tauto. Qed. -Lemma svalid_set_proof d x t m: - svalid ge d m -> term_eval ge t m <> None -> svalid ge (smem_set d x t) m. +Lemma smem_valid_set_proof d x t m: + smem_valid ge d m -> term_eval ge t m <> None -> smem_valid ge (smem_set d x t) m. Proof. - unfold svalid; intros (PRE & VALID) PREt. split. + unfold smem_valid; intros (PRE & VALID) PREt. split. + split; auto. + intros x0; case (R.eq_dec x x0). - intros; subst; autorewrite with dict_rw. auto. -- cgit From 0bd3d3c9cb1445a588ed4f254c5e036a213801c1 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 28 May 2019 07:13:39 +0200 Subject: simpler definition of reduce --- mppa_k1c/Asmblockdeps.v | 19 ++++- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 123 ++++++++++++++++++++------- mppa_k1c/abstractbb/ImpSimuTest.v | 39 +++++---- 3 files changed, 133 insertions(+), 48 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index e0aaee58..55a02633 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1579,20 +1579,31 @@ Definition is_constant (o: op): bool := | _ => false end. -Program Definition failsafe_reduce := Terms.failsafe_reduce is_constant. -Obligation 1. +Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None. +Proof. destruct o; simpl in * |- *; try congruence. destruct ao; simpl in * |- *; try congruence; destruct n; simpl in * |- *; try congruence; unfold arith_eval; destruct ge; simpl in * |- *; try congruence. Qed. +Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t). + +Local Hint Resolve is_constant_correct: wlp. + +Lemma main_reduce_correct t: + WHEN main_reduce t ~> pt THEN Terms.match_pt t pt. +Proof. + wlp_simplify. +Qed. + +Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}. Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := if verb then - IST.verb_bblock_simu_test failsafe_reduce string_of_name string_of_op (trans_block p1) (trans_block p2) + IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2) else - IST.bblock_simu_test failsafe_reduce (trans_block p1) (trans_block p2). + IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 8ee04f44..43c70ae5 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,5 +1,6 @@ (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) +Require Import Setoid. Require Import ImpPrelude. Module Type PseudoRegisters. @@ -303,50 +304,114 @@ Definition list_term_get_hid (l: list_term): hashcode := end. -Definition allvalid ge (l: list term) m := forall t, List.In t l -> term_eval ge t m <> None. +Fixpoint allvalid ge (l: list term) m : Prop := + match l with + | nil => True + | t::nil => term_eval ge t m <> None + | t::l' => term_eval ge t m <> None /\ allvalid ge l' m + end. + +Lemma allvalid_extensionality ge (l: list term) m: + allvalid ge l m <-> (forall t, List.In t l -> term_eval ge t m <> None). +Proof. + induction l as [|t l]; simpl; try (tauto). + destruct l. + - intuition (congruence || eauto). + - rewrite IHl; clear IHl. intuition (congruence || eauto). +Qed. -Record pseudo_term: Type := { +Record pseudo_term: Type := intro_fail { mayfail: list term; effect: term }. -Definition match_pseudo_term (t: term) (pt: pseudo_term) := +Definition match_pt (t: term) (pt: pseudo_term) := (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). -Import ImpCore.Notations. -Local Open Scope impure_scope. +Lemma intro_fail_correct (l: list term) (t: term) : + (forall ge m, term_eval ge t m <> None <-> allvalid ge l m) -> match_pt t (intro_fail l t). +Proof. + unfold match_pt; simpl; intros; intuition congruence. +Qed. +Hint Resolve intro_fail_correct: wlp. -Record reduction (t:term):= { - result:> ?? pseudo_term; - result_correct: WHEN result ~> pt THEN match_pseudo_term t pt; -}. -Hint Resolve result_correct: wlp. +Definition identity_fail (t: term):= intro_fail [t] t. -Program Definition identity_reduce (t: term): reduction t := {| result := RET {| mayfail := [t]; effect := t |} |}. -Obligation 1. - unfold match_pseudo_term, allvalid; wlp_simplify; congruence. +Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). +Proof. + eapply intro_fail_correct; simpl; tauto. Qed. -Global Opaque identity_reduce. +Global Opaque identity_fail. +Hint Resolve identity_fail_correct: wlp. + +Definition nofail (is_constant: op -> bool) (t: term):= + match t with + | Input x _ => intro_fail ([])%list t + | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t) + | _ => identity_fail t + end. + +Lemma nofail_correct (is_constant: op -> bool) t: + (forall ge o, is_constant o = true -> op_eval ge o nil <> None) -> match_pt t (nofail is_constant t). +Proof. + destruct t; simpl. + + intros; eapply intro_fail_correct; simpl; intuition congruence. + + intros; destruct l; simpl; auto with wlp. + destruct (is_constant o) eqn:Heqo; simpl; intuition eauto with wlp. + eapply intro_fail_correct; simpl; intuition eauto with wlp. +Qed. +Global Opaque nofail. +Hint Resolve nofail_correct: wlp. -Program Definition failsafe_reduce (is_constant: op -> bool | forall ge o, is_constant o = true -> op_eval ge o nil <> None) (t: term) := - match t with - | Input x _ => {| result := RET {| mayfail := []; effect := t |} |} - | o @ [] => match is_constant o with - | true => {| result := RET {| mayfail := []; effect := t |} |} - | false => identity_reduce t - end - | _ => identity_reduce t - end. -Obligation 1. - unfold match_pseudo_term, allvalid; simpl; wlp_simplify; congruence. +Definition term_equiv t1 t2:= forall ge m, term_eval ge t1 m = term_eval ge t2 m. + +Global Instance term_equiv_Equivalence : Equivalence term_equiv. +Proof. + split; intro x; unfold term_equiv; intros; eauto. + eapply eq_trans; eauto. Qed. -Obligation 2. - unfold match_pseudo_term, allvalid; simpl; wlp_simplify. + +Lemma match_pt_term_equiv t1 t2 pt: term_equiv t1 t2 -> match_pt t1 pt -> match_pt t2 pt. +Proof. + unfold match_pt, term_equiv. + intros H. intuition; try (erewrite <- H1 in * |- *; congruence). + erewrite <- H2; eauto; congruence. Qed. -Obligation 3. - intuition congruence. +Hint Resolve match_pt_term_equiv: wlp. + +Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term := + {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}. + +Lemma app_fail_correct l pt t1 t2: + match_pt t1 pt -> + match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> + match_pt t2 (app_fail l pt). +Proof. + unfold match_pt in * |- *. + intros (XV & XE) (YV & YE). + split; intros ge m; try (simpl; auto; fail). + generalize (XV ge m) (YV ge m); rewrite !allvalid_extensionality; simpl. clear XV XE YV YE. + intuition subst. + + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto. + + eapply H3; eauto. + intros. intuition subst. + * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. + * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. Qed. +Hint Resolve app_fail_correct: wlp. +Extraction Inline app_fail. +Global Opaque app_fail. + + +Import ImpCore.Notations. +Local Open Scope impure_scope. + +Record reduction:= { + result:> term -> ?? pseudo_term; + result_correct: forall t, WHEN result t ~> pt THEN match_pt t pt; +}. +Hint Resolve result_correct: wlp. End Terms. diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 13af4289..8f6b05b7 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -67,20 +67,20 @@ Declare Module CoreL: ISeqLanguage. Import CoreL. Import Terms. -Parameter bblock_simu_test: (forall t : term, reduction t) -> bblock -> bblock -> ?? bool. +Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool. -Parameter bblock_simu_test_correct: forall (reduce: forall t, reduction t) (p1 p2 : bblock), +Parameter bblock_simu_test_correct: forall reduce (p1 p2 : bblock), WHEN bblock_simu_test reduce p1 p2 ~> b THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. Parameter verb_bblock_simu_test - : (forall t : term, reduction t) -> + : reduction -> (R.t -> ?? pstring) -> (op -> ?? pstring) -> bblock -> bblock -> ?? bool. Parameter verb_bblock_simu_test_correct: - forall (reduce: forall t, reduction t) + forall reduce (string_of_name : R.t -> ?? pstring) (string_of_op : op -> ?? pstring) (p1 p2 : bblock), @@ -128,7 +128,7 @@ Module D:=ImpPrelude.Dict. Section SimuWithReduce. -Variable reduce: forall t, reduction t. +Variable reduce: reduction. Section CanonBuilding. @@ -230,6 +230,8 @@ Qed. Global Opaque hsmem_get. Hint Resolve hsmem_get_correct: wlp. +Local Opaque allvalid. + Definition smem_model ge (d: smem) (hd:hsmem): Prop := (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) /\ (forall m x, smem_valid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). @@ -262,7 +264,7 @@ Proof. destruct (DM0 m) as (PRE & VALID0); clear DM0. assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold smem_valid in PRE; tauto. } - unfold allvalid in * |- *; simpl. + rewrite !allvalid_extensionality in * |- *; simpl. intuition (subst; eauto). + eapply smem_valid_set_proof; eauto. erewrite <- EQT; eauto. @@ -351,8 +353,10 @@ Lemma hterm_append_correct l: forall lh, WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)). Proof. Local Hint Resolve eq_trans: localhint. - unfold allvalid; induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). - intros REC ge m; rewrite REC; clear IHl' REC. intuition (subst; eauto with wlp localhint). + induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). + - intros; rewrite! allvalid_extensionality; intuition eauto. + - intros REC ge m; rewrite REC; clear IHl' REC. rewrite !allvalid_extensionality. + simpl; intuition (subst; eauto with wlp localhint). Qed. (*Local Hint Resolve hterm_append_correct: wlp.*) Global Opaque hterm_append. @@ -406,14 +410,14 @@ Proof. eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. destruct H as (VALID & EFFECT); split. - intros; rewrite APPEND, <- VALID. - unfold allvalid; simpl; intuition (subst; eauto). + rewrite !allvalid_extensionality in * |- *; simpl; intuition (subst; eauto). - intros m x0 ALLVALID; rewrite SMART. destruct (term_eval ge ht m) eqn: Hht. * case (R.eq_dec x x0). + intros; subst. unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. erewrite LIFT, EFFECT; eauto. + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. - * destruct (ALLVALID ht); simpl; auto. + * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. Qed. Local Hint Resolve hsmem_set_correct: wlp. Global Opaque hsmem_set. @@ -520,11 +524,13 @@ Local Hint Resolve hbblock_smem_rec_correct: wlp. Definition hbblock_smem: bblock -> ?? hsmem := fun p => hbblock_smem_rec p {| hpre:= nil ; hpost := Dict.empty |}. +Transparent allvalid. + Lemma hbblock_smem_correct p: WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, smem_valid, smem_eval, allvalid, smem_eval, smem_get; simpl; intuition; + unfold smem_model, smem_valid, smem_eval, smem_get; simpl; intuition; rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. Qed. Global Opaque hbblock_smem. @@ -649,12 +655,14 @@ Obligation 1. destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. apply bblock_smem_simu; auto. + intros m; rewrite <- EQPRE1, <- EQPRE2. - unfold incl, allvalid in * |- *; intuition eauto. + rewrite ! allvalid_extensionality. + unfold incl in * |- *; intuition eauto. + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. erewrite smem_eval_intro; eauto. erewrite <- EQPRE2; auto. erewrite <- EQPRE1 in VALID. - unfold incl, allvalid in * |- *; intuition eauto. + rewrite ! allvalid_extensionality in * |- *. + unfold incl in * |- *; intuition eauto. Qed. Theorem g_bblock_simu_test_correct p1 p2: @@ -1011,9 +1019,10 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO cr <~ make_cref None;; DO hco_term <~ mk_annot (hCons hht);; DO hco_list <~ mk_annot (hCons hlht);; - DO result2 <~ g_bblock_simu_test + DO result2 <~ g_bblock_simu_test (log_assign dict_info log1) - (log_new_term (msg_term cr)) + (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *) + (log_new_term (msg_term cr)) (* REM: too strong ?? *) (hlog log1 hco_term hco_list) (log_insert log2) hco_term _ -- cgit From 9f111987bb820d2a2b92441752c0d5c0c5df8033 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Tue, 28 May 2019 17:35:03 +0200 Subject: minor change in auxiliary lemma --- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 32 ++++++++++++++++++---------- 1 file changed, 21 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 43c70ae5..5c94d435 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -325,6 +325,13 @@ Record pseudo_term: Type := intro_fail { effect: term }. +Lemma inf_option_equivalence (A:Type) (o1 o2: option A): + (o1 <> None -> o1 = o2) <-> (forall m1, o1 = Some m1 -> o2 = Some m1). +Proof. + destruct o1; intuition (congruence || eauto). + symmetry; eauto. +Qed. + Definition match_pt (t: term) (pt: pseudo_term) := (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). @@ -383,15 +390,12 @@ Hint Resolve match_pt_term_equiv: wlp. Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term := {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}. -Lemma app_fail_correct l pt t1 t2: - match_pt t1 pt -> - match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> - match_pt t2 (app_fail l pt). +Lemma app_fail_allvalid_correct l pt t1 t2: forall + (V1: forall (ge : genv) (m : mem), term_eval ge t1 m <> None <-> allvalid ge (mayfail pt) m) + (V2: forall (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail {| mayfail := t1 :: l; effect := t1 |}) m) + (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail (app_fail l pt)) m. Proof. - unfold match_pt in * |- *. - intros (XV & XE) (YV & YE). - split; intros ge m; try (simpl; auto; fail). - generalize (XV ge m) (YV ge m); rewrite !allvalid_extensionality; simpl. clear XV XE YV YE. + intros; generalize (V1 ge m) (V2 ge m); rewrite !allvalid_extensionality; simpl. clear V1 V2. intuition subst. + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto. + eapply H3; eauto. @@ -399,10 +403,16 @@ Proof. * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. Qed. -Hint Resolve app_fail_correct: wlp. -Extraction Inline app_fail. -Global Opaque app_fail. +Local Hint Resolve app_fail_allvalid_correct. +Lemma app_fail_correct l pt t1 t2: + match_pt t1 pt -> + match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> + match_pt t2 (app_fail l pt). +Proof. + unfold match_pt in * |- *; intros (V1 & E1) (V2 & E2); split; intros ge m; try (eauto; fail). +Qed. +Extraction Inline app_fail. Import ImpCore.Notations. Local Open Scope impure_scope. -- cgit From 487fc42595bb43450f2b0b5a49b4edbc22892b9f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 3 Jun 2019 22:26:06 +0200 Subject: rm old select/selectl/selectf/selectfs --- mppa_k1c/Archi.v | 23 ++-- mppa_k1c/Asmblockgen.v | 21 ---- mppa_k1c/Asmblockgenproof1.v | 244 ------------------------------------------- mppa_k1c/ExtValues.v | 6 +- mppa_k1c/Machregs.v | 1 - mppa_k1c/NeedOp.v | 182 -------------------------------- mppa_k1c/Op.v | 135 ++---------------------- mppa_k1c/SelectLong.vp | 19 ---- mppa_k1c/SelectLongproof.v | 75 ------------- mppa_k1c/SelectOp.vp | 47 +-------- mppa_k1c/SelectOpproof.v | 97 ++++------------- mppa_k1c/ValueAOp.v | 44 -------- 12 files changed, 44 insertions(+), 850 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index bbe66c5b..113f5d51 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -17,8 +17,8 @@ (** Architecture-dependent parameters for RISC-V *) Require Import ZArith. -Require Import Fappli_IEEE. -Require Import Fappli_IEEE_bits. +(*From Flocq*) +Require Import Binary Bits. Definition ptr64 := true. @@ -41,23 +41,26 @@ Qed. We need to extend the [choose_binop_pl] functions to account for this case. *) -Program Definition default_pl_64 : bool * nan_pl 53 := - (false, iter_nat 51 _ xO xH). +Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := + exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) := +Definition choose_binop_pl_64 (pl1 pl2 : positive) := false. (**r always choose first NaN *) -Program Definition default_pl_32 : bool * nan_pl 24 := - (false, iter_nat 22 _ xO xH). +Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := + exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). -Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) := +Definition choose_binop_pl_32 (pl1 pl2 : positive) := false. (**r always choose first NaN *) +(* TODO check *) +Definition fpu_returns_default_qNaN := false. + Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_pl_64 choose_binop_pl_64 - default_pl_32 choose_binop_pl_32 + default_nan_64 choose_binop_pl_64 + default_nan_32 choose_binop_pl_32 float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 941796cd..33fa39b5 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -784,31 +784,10 @@ Definition transl_op | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") - | Ocmp cmp, _ => do rd <- ireg_of res; transl_cond_op cmp rd args k - | Oselect cond, a0 :: a1 :: aS :: nil - | Oselectl cond, a0 :: a1 :: aS :: nil - | Oselectf cond, a0 :: a1 :: aS :: nil - | Oselectfs cond, a0 :: a1 :: aS :: nil => - assertion (mreg_eq a0 res); - do r0 <- ireg_of a0; - do r1 <- ireg_of a1; - do rS <- ireg_of aS; - (match cond with - | Ccomp0 cmp => - OK (Pcmove (btest_for_cmpswz cmp) r0 rS r1 ::i k) - | Ccompu0 cmp => - do bt <- btest_for_cmpuwz cmp; - OK (Pcmoveu bt r0 rS r1 ::i k) - | Ccompl0 cmp => - OK (Pcmove (btest_for_cmpsdz cmp) r0 rS r1 ::i k) - | Ccomplu0 cmp => - do bt <- btest_for_cmpudz cmp; - OK (Pcmoveu bt r0 rS r1 ::i k) - end) | Oextfz stop start, a1 :: nil => assertion (ExtValues.is_bitfield stop start); diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 3c1162bd..8125741b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1719,250 +1719,6 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. -- (* Oselect *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - -- (* Oselectl *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - -- (* Oselectf *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - -- (* Oselectfs *) - destruct cond in *; simpl in *; try congruence; - try monadInv EQ3; - try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew); - econstructor; split; - try ( eapply exec_straight_one; simpl; reflexivity ). - (* Cmp *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmp_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - (* Cmpu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))). - destruct (Val.cmpu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmpl *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl; - destruct (Val.cmpl_bool _ _); simpl; try constructor; - destruct b; simpl; rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. - - (* Cmplu *) - + split. - * unfold eval_select. - destruct (rs x) eqn:eqX; try constructor. - destruct (rs x0) eqn:eqX0; try constructor. - destruct c0 in *; simpl in *; inv EQ2; simpl. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))). - destruct (Val.cmplu_bool _ _); simpl; try constructor. - destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial; - rewrite Pregmap.gss; constructor. - * intros. - rewrite Pregmap.gso; congruence. Qed. (** Memory accesses *) diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 155afa83..8e6aa028 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -287,10 +287,10 @@ Proof. intros. apply Int.eqm_samerepr. unfold Int.eqm. - unfold Int.eqmod. + unfold Zbits.eqmod. pose proof (Int64.eqm_unsigned_repr x) as H64. unfold Int64.eqm in H64. - unfold Int64.eqmod in H64. + unfold Zbits.eqmod in H64. destruct H64 as [k64 H64]. change Int64.modulus with 18446744073709551616 in *. change Int.modulus with 4294967296. @@ -367,7 +367,7 @@ Proof. apply Int.eqm_samerepr. unfold Int.eqm. change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968. - unfold Int.eqmod. + unfold Zbits.eqmod. change Int.modulus with 4294967296. exists (-4294967296). compute. diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index db3dfe64..4e8eedda 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,7 +216,6 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl - | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 5ba9851f..746b21a6 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -129,7 +129,6 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) | Ocmp c => needs_of_condition c - | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv) | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) end. @@ -277,179 +276,6 @@ Proof. trivial. Qed. -Lemma select_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_select cond v0 v1 v2 m1) (eval_select cond w0 w1 w2 m2) x. -Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_select_to2. - rewrite eval_select_to2. - unfold eval_select2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - apply iagree_refl. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - apply iagree_refl. - - rewrite eval_select_to2. - rewrite eval_select_to2. - unfold eval_select2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. -Qed. - -Lemma selectl_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectl cond v0 v1 v2 m1) (eval_selectl cond w0 w1 w2 m2) x. -Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectl_to2. - rewrite eval_selectl_to2. - unfold eval_selectl2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectl_to2. - rewrite eval_selectl_to2. - unfold eval_selectl2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. -Qed. - -Lemma selectf_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectf cond v0 v1 v2 m1) (eval_selectf cond w0 w1 w2 m2) x. -Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectf_to2. - rewrite eval_selectf_to2. - unfold eval_selectf2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectf_to2. - rewrite eval_selectf_to2. - unfold eval_selectf2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. -Qed. - -Lemma selectfs_sound: - forall cond v0 w0 v1 w1 v2 w2 x, - vagree v0 w0 (default x) -> - vagree v1 w1 (default x) -> - vagree v2 w2 (default x) -> - vagree (eval_selectfs cond v0 v1 v2 m1) (eval_selectfs cond w0 w1 w2 m2) x. -Proof. - intros. - destruct x; simpl in *; trivial. - - rewrite eval_selectfs_to2. - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - destruct w1; trivial. - - rewrite eval_selectfs_to2. - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)). - assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)). - destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial. - destruct b. - + rewrite Hneedstrue; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. - + rewrite Hneedsfalse; trivial. - inv H; trivial. - destruct w0; trivial. - inv H0; trivial. -Qed. Remark default_idem: forall nv, default (default nv) = default nv. Proof. @@ -514,14 +340,6 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. - (* select *) -- apply select_sound; trivial. - (* selectl *) -- apply selectl_sound; trivial. - (* selectf *) -- apply selectf_sound; trivial. - (* selectfs *) -- apply selectfs_sound; trivial. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4df157b0..24572e13 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -204,10 +204,6 @@ Inductive operation : Type := | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) (*c Boolean tests: *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - | Oselect (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectl (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectf (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) - | Oselectfs (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *) | Oextfz (stop : Z) (start : Z) | Oextfs (stop : Z) (start : Z) | Oextfzl (stop : Z) (start : Z) @@ -304,24 +300,24 @@ Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) end. -Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := +Definition eval_selecti (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := match v0, v1, (eval_condition0 cond vselect m) with | Vint i0, Vint i1, Some bval => Vint (if bval then i1 else i0) | _,_,_ => Vundef end. -Definition eval_select2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := +Definition eval_selecti2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := match (eval_condition0 cond vselect m), v0, v1 with | Some bval, Vint i0, Vint i1 => Vint (if bval then i1 else i0) | _,_,_ => Vundef end. -Lemma eval_select_to2: forall cond v0 v1 vselect m, - (eval_select cond v0 v1 vselect m) = - (eval_select2 cond v0 v1 vselect m). +Lemma eval_selecti_to2: forall cond v0 v1 vselect m, + (eval_selecti cond v0 v1 vselect m) = + (eval_selecti2 cond v0 v1 vselect m). Proof. intros. - unfold eval_select2. + unfold eval_selecti2. destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. Qed. @@ -526,10 +522,6 @@ Definition eval_operation | Osingleoflong, v1::nil => Val.singleoflong v1 | Osingleoflongu, v1::nil => Val.singleoflongu v1 | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) - | (Oselect cond), v0::v1::vselect::nil => Some (eval_select cond v0 v1 vselect m) - | (Oselectl cond), v0::v1::vselect::nil => Some (eval_selectl cond v0 v1 vselect m) - | (Oselectf cond), v0::v1::vselect::nil => Some (eval_selectf cond v0 v1 vselect m) - | (Oselectfs cond), v0::v1::vselect::nil => Some (eval_selectfs cond v0 v1 vselect m) | (Oextfz stop start), v0::nil => Some (extfz stop start v0) | (Oextfs stop start), v0::nil => Some (extfs stop start v0) | (Oextfzl stop start), v0::nil => Some (extfzl stop start v0) @@ -734,12 +726,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Olonguofsingle => (Tsingle :: nil, Tlong) | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) - | Ocmp c => (type_of_condition c, Tint) - - | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint) - | Oselectl cond => (Tlong :: Tlong :: (arg_type_of_condition0 cond) :: nil, Tlong) - | Oselectf cond => (Tfloat :: Tfloat :: (arg_type_of_condition0 cond) :: nil, Tfloat) - | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) | Oinsf _ _ => (Tint :: Tint :: nil, Tint) @@ -1021,43 +1008,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; simpl in H0; inv H0... (* cmp *) - destruct (eval_condition cond vl m)... destruct b... - (* select *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - (* selectl *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - - (* selectf *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - (* selectfs *) - - destruct v0; destruct v1; simpl in *; try discriminate; trivial. - destruct cond; destruct v2; simpl in *; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. - + destruct Archi.ptr64; simpl; trivial. - destruct (_ && _); simpl; trivial. - destruct (Val.cmp_different_blocks _); simpl; trivial. (* extfz *) - unfold extfz. destruct (is_bitfield _ _). @@ -1250,19 +1200,6 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 - - | Oselect (Ccompu0 _) => negb Archi.ptr64 - | Oselect (Ccomplu0 _) => Archi.ptr64 - - | Oselectl (Ccompu0 _) => negb Archi.ptr64 - | Oselectl (Ccomplu0 _) => Archi.ptr64 - - | Oselectf (Ccompu0 _) => negb Archi.ptr64 - | Oselectf (Ccomplu0 _) => Archi.ptr64 - - | Oselectfs (Ccompu0 _) => negb Archi.ptr64 - | Oselectfs (Ccomplu0 _) => Archi.ptr64 - | _ => false end. @@ -1274,7 +1211,7 @@ Proof. intros until m2. destruct op; simpl; try congruence; destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold eval_select, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + unfold eval_selecti, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1668,62 +1605,6 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. - (* select *) - - unfold eval_select. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectl *) - - unfold eval_selectl. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectf *) - - unfold eval_selectf. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. - (* selectfs *) - - unfold eval_selectfs. - inv H4; trivial. - inv H2; trivial. - inv H3; trivial; - try (destruct cond; simpl; trivial; fail). - destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial. - eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b). - * eapply eval_condition0_inj. - eapply Val.inject_ptr. - eassumption. - reflexivity. - assumption. - * rewrite Hcond'. constructor. (* extfz *) - unfold extfz. diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 4e369e11..981c796c 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -306,14 +306,6 @@ Nondetfunction andl (e1: expr) (e2: expr) := | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) | _, _ => Eop Oandl (e1:::e2:::Enil) end. -(* - | (Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1)) - (y1:::Enil)):::Enil)):::Enil)), v1 => - if Int64.eq zero1 Int64.zero - then Eop Oselectl ((Eop (Olongconst Int64.zero) Enil):::v1:::y1:::Enil) - else Eop Oandl (e1:::e2:::Enil) -*) Nondetfunction orlimm (n1: int64) (e2: expr) := if Int64.eq n1 Int64.zero then e2 else @@ -332,17 +324,6 @@ Nondetfunction orl (e1: expr) (e2: expr) := | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 | (Eop Onotl (t1:::Enil)), t2 => Eop Oornl (t1:::t2:::Enil) | t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil) - | (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Ceq zero0)) - (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)), - (Eop Oandl ((Eop Ocast32signed - ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1)) - (y1:::Enil)):::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int64.eq zero0 Int64.zero - && Int64.eq zero1 Int64.zero - then Eop (Oselectl (Ccompl0 Cne)) (v0:::v1:::y0:::Enil) - else Eop Oorl (e1:::e2:::Enil) | (Eop (Oandlimm nmask) (prev:::Enil)), (Eop (Oandlimm mask) ((Eop (Oshllimm start) (fld:::Enil)):::Enil)) => diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 78a2bb31..ada02585 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -660,81 +660,6 @@ Proof. - InvEval. apply eval_orlimm; auto. - (*orn*) InvEval. TrivialExists; simpl; congruence. - (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence. - - (* selectl *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try TrivialExists. - predSpec Int64.eq Int64.eq_spec zero0 Int64.zero; simpl; try TrivialExists. - predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; [ | TrivialExists]. - inv H. - inv H0. - inv H6. - inv H3. - inv H2. - inv H7. - inv H4. - inv H3. - inv H6. - inv H4. - inv H3. - inv H14. - inv H13. - inv H6. - inv H4. - inv H13. - inv H14. - inv H9. - inv H11. - inv H13. - inv H3. - inv H6. - inv H7. - inv H3. - inv H14. - inv H17. - simpl in *. - inv H8. - inv H5. - inv H10. - inv H12. - inv H15. - inv H16. - inv H11. - inv H13. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence; clear PURE. - rewrite <- e0 in *; clear e0. - inv H6. - inv H7. - rename v10 into vtest. - replace v11 with vtest in * by congruence. - TrivialExists. - simpl. - f_equal. - rewrite eval_selectl_to2. - unfold eval_selectl2. - destruct vtest; simpl; trivial. - rewrite Val.andl_commut. - destruct v4; simpl; trivial. - rewrite Val.andl_commut. - rewrite Val.orl_commut. - destruct v9; simpl; trivial. - rewrite int64_eq_commut. - destruct (Int64.eq Int64.zero i1); simpl. - - + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. - replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. - rewrite Int64.and_mone. - rewrite Int64.and_zero. - rewrite Int64.or_commut. - rewrite Int64.or_zero. - reflexivity. - + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. - replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. - rewrite Int64.and_mone. - rewrite Int64.and_zero. - rewrite Int64.or_zero. - reflexivity. - (*insfl first case*) destruct (is_bitfieldl _ _) eqn:Risbitfield. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 23d234aa..219a462b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,33 +66,8 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -Definition select_base o0 o1 oselect := - Eop (Oselect (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition select o0 o1 oselect := - select_base o0 o1 oselect. - -Definition selectl_base o0 o1 oselect := - Eop (Oselectl (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectl o0 o1 oselect := - selectl_base o0 o1 oselect. - -Definition selectf_base o0 o1 oselect := - Eop (Oselectf (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectf o0 o1 oselect := - selectf_base o0 o1 oselect. - -Definition selectfs_base o0 o1 oselect := - Eop (Oselectfs (Ccomp0 Cne)) - (o0:::o1:::oselect:::Enil). - -Definition selectfs o0 o1 oselect := - selectfs_base o0 o1 oselect. +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := None. + (** ** Constants **) @@ -349,24 +324,6 @@ Nondetfunction or (e1: expr) (e2: expr) := else Eop Oor (e1:::e2:::Enil) | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) | t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil) - | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Ceq zero0)) - (y0:::Enil)):::Enil)):::v0:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Cne zero1)) - (y1:::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int.eq zero0 Int.zero - && Int.eq zero1 Int.zero - then select_base v0 v1 y0 - else Eop Oor (e1:::e2:::Enil) - | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Ceq zero0)) - (y0:::Enil)):::Enil)):::v0:::Enil)), - (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Cne zero1)) - (y1:::Enil)):::Enil)):::v1:::Enil)) => - if same_expr_pure y0 y1 - && Int.eq zero0 Int.zero - && Int.eq zero1 Int.zero - then select_base v0 v1 y0 - else Eop Oor (e1:::e2:::Enil) | (Eop (Oandimm nmask) (prev:::Enil)), (Eop (Oandimm mask) ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index a5154611..26f1bb89 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -609,7 +609,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhs; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -637,7 +637,7 @@ Proof. change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. apply Val.lessdef_same. f_equal. transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity. + unfold Int.mulhu; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. apply Int.same_bits_eq; intros n N. change Int.zwordsize with 32 in *. assert (N1: 0 <= n < 64) by omega. @@ -756,83 +756,6 @@ Proof. exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. - (*orn*) TrivialExists; simpl; congruence. - (*orn reversed*) rewrite Val.or_commut. TrivialExists; simpl; congruence. - - (* select *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. - TrivialExists. - simpl in *. - unfold eval_select. - f_equal. - inv H6. - inv H7. - inv H9. - inv H11. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence. - rewrite <- e0 in *. clear e0. clear PURE. - inv H2. inv H5. - replace v8 with v4 in * by congruence. - rename v4 into vselect. - destruct vselect; simpl; trivial; - destruct v5; simpl; trivial; destruct v9; simpl; trivial; - destruct (Int.eq i1 Int.zero); simpl; trivial. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_zero. - reflexivity. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.or_commut. - rewrite Int.or_zero. - reflexivity. - - (* select unsigned *) - destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT. - predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT. - TrivialExists. - simpl in *. - unfold eval_select. - f_equal. - inv H6. - inv H7. - inv H9. - inv H11. - unfold same_expr_pure in PURE. - destruct y0; try congruence. - destruct y1; try congruence. - destruct (ident_eq i i0); try congruence. - rewrite <- e0 in *. clear e0. clear PURE. - inv H2. inv H5. - replace v8 with v4 in * by congruence. - rename v4 into vselect. - destruct vselect; simpl; trivial; - destruct v5; simpl; trivial; - destruct v9; simpl; trivial; - destruct (Int.eq i1 Int.zero); simpl; trivial. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.or_zero. - reflexivity. - + rewrite Int.neg_zero. - rewrite Int.and_commut. - rewrite Int.and_zero. - rewrite Int.and_commut. - rewrite Int.and_mone. - rewrite Int.or_commut. - rewrite Int.or_zero. - reflexivity. - set (zstop := (int_highest_bit mask)). set (zstart := (Int.unsigned start)). destruct (is_bitfield _ _) eqn:Risbitfield. @@ -1488,6 +1411,22 @@ Proof. - constructor; auto. Qed. +(* ternary *) + +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + discriminate. +Qed. + (* floating-point division *) Theorem eval_divf_base: forall le a b x y, diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f41dae63..f0cdf24e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -282,10 +282,6 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | (Oselect cond), v0::v1::vselect::nil => eval_static_select cond v0 v1 vselect - | (Oselectl cond), v0::v1::vselect::nil => eval_static_selectl cond v0 v1 vselect - | (Oselectf cond), v0::v1::vselect::nil => eval_static_selectf cond v0 v1 vselect - | (Oselectfs cond), v0::v1::vselect::nil => eval_static_selectfs cond v0 v1 vselect | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0 | (Oextfs stop start), v0::nil => eval_static_extfs stop start v0 | (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0 @@ -411,46 +407,6 @@ Proof. + eauto with va. + destruct a1; destruct shift; reflexivity. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - (* select *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_select_to2. - unfold eval_select2. - inv Hcond; trivial; try constructor. - + apply binop_int_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_i. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_i. - (* selectl *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectl_to2. - unfold eval_selectl2. - inv Hcond; trivial; try constructor. - + apply binop_long_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_l. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - apply vmatch_ifptr_l. - (* selectf *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectf_to2. - unfold eval_selectf2. - inv Hcond; trivial; try constructor. - + apply binop_float_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - (* selectfs *) - - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption). - rewrite eval_selectfs_to2. - unfold eval_selectfs2. - inv Hcond; trivial; try constructor. - + apply binop_single_sound; assumption. - + destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. - + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef. - constructor. (* extfz *) - unfold extfz, eval_static_extfz. -- cgit From 0daaa4c00119fe19872bab38aacf01c34d465c5f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 07:15:19 +0200 Subject: Osel operation (not yet compiled) --- mppa_k1c/NeedOp.v | 7 +++++++ mppa_k1c/Op.v | 34 ++++++++++++++++++++++++++++------ mppa_k1c/ValueAOp.v | 29 ++++------------------------- 3 files changed, 39 insertions(+), 31 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 746b21a6..047c180a 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -28,6 +28,7 @@ Definition op2 (nv: nval) := nv :: nv :: nil. Definition op3 (nv: nval) := nv :: nv :: nv :: nil. Definition needs_of_condition (cond: condition): list nval := nil. +Definition needs_of_condition0 (cond0: condition0): list nval := nil. Definition needs_of_operation (op: operation) (nv: nval): list nval := match op with @@ -131,6 +132,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Ocmp c => needs_of_condition c | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) + | Osel c ty => nv :: nv :: needs_of_condition0 c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -340,6 +342,11 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. + (* select *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto. + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 24572e13..c7c04d83 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -209,7 +209,8 @@ Inductive operation : Type := | Oextfzl (stop : Z) (start : Z) | Oextfsl (stop : Z) (start : Z) | Oinsf (stop : Z) (start : Z) - | Oinsfl (stop : Z) (start : Z). + | Oinsfl (stop : Z) (start : Z) + | Osel (c0 : condition0) (ty : typ). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -250,7 +251,7 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. + generalize typ_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. decide equality. Defined. @@ -528,6 +529,7 @@ Definition eval_operation | (Oextfsl stop start), v0::nil => Some (extfsl stop start v0) | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) + | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) | _, _ => None end. @@ -731,6 +733,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) | Oinsf _ _ => (Tint :: Tint :: nil, Tint) | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) + | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) end. (* FIXME: two Tptr ?! *) @@ -1040,6 +1043,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + destruct v0; destruct v1; simpl; trivial. destruct (Int.ltu _ _); simpl; trivial. + constructor. + (* Osel *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. Qed. End SOUNDNESS. @@ -1200,6 +1207,10 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 + + | Osel (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ => Archi.ptr64 + | _ => false end. @@ -1208,10 +1219,13 @@ Lemma op_depends_on_memory_correct: op_depends_on_memory op = false -> eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. - intros until m2. destruct op; simpl; try congruence; - - destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF; - unfold eval_selecti, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + intros until m2. destruct op; simpl; try congruence. + - destruct cond; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1645,6 +1659,14 @@ Proof. simpl. destruct (Int.ltu _ _); trivial. simpl. trivial. + trivial. + + (* Osel *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index f0cdf24e..d24cebcc 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -51,30 +51,6 @@ Definition eval_static_condition0 (cond : condition0) (v : aval) : abool := | Ccomplu0 c => cmplu_bool c v (L Int64.zero) end. -Definition eval_static_select (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_int (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectl (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_long (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectf (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_float (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - -Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : aval := - match eval_static_condition0 cond vselect with - | Just b => binop_single (fun x0 x1 => if b then x1 else x0) v0 v1 - | _ => Vtop - end. - Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := if is_bitfield stop start @@ -288,6 +264,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0 | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 + | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 | _, _ => Vbot end. @@ -367,7 +344,7 @@ Theorem eval_static_operation_sound: list_forall2 (vmatch bc) vargs aargs -> vmatch bc vres (eval_static_operation op aargs). Proof. - unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs, addx, revsubx, addxl, revsubxl; intros. + unfold eval_operation, eval_static_operation, addx, revsubx, addxl, revsubxl; intros. destruct op; InvHyps; eauto with va. - destruct (propagate_float_constants tt); constructor. - destruct (propagate_float_constants tt); constructor. @@ -442,6 +419,8 @@ Proof. destruct (is_bitfieldl _ _). + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + constructor. + (* select *) + - apply select_sound; auto. eapply eval_static_condition0_sound; eauto. Qed. End SOUNDNESS. -- cgit From 30f549e4e04567e35fb6a4eda269132f6cd22dd1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 07:26:55 +0200 Subject: Osel is output = 1st input --- mppa_k1c/Machregs.v | 1 + 1 file changed, 1 insertion(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 4e8eedda..ee3a63c7 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,6 +216,7 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl + | Osel _ _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. -- cgit From eec7948bd0204787ad8ddde70c5a28fdfd62356a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 11:25:11 +0200 Subject: Osel -> assembleur --- mppa_k1c/Asmblockgen.v | 71 ++++++++++++++++++++++++----------- mppa_k1c/Asmblockgenproof1.v | 57 ++++++++++++++++++++++++++++ mppa_k1c/Op.v | 88 +++----------------------------------------- 3 files changed, 112 insertions(+), 104 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 33fa39b5..72d7394b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -334,6 +334,47 @@ Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) | Reversed ft => Pfcompl ft rd r2 r1 ::i k end. + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpuwz (c: comparison) := + match c with + | Cne => OK BTwnez + | Ceq => OK BTweqz + | Clt => Error (msg "btest_for_compuwz: Clt") + | Cge => Error (msg "btest_for_compuwz: Cge") + | Cle => Error (msg "btest_for_compuwz: Cle") + | Cgt => Error (msg "btest_for_compuwz: Cgt") + end. + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpudz (c: comparison) := + match c with + | Cne => OK BTdnez + | Ceq => OK BTdeqz + | Clt => Error (msg "btest_for_compudz: Clt") + | Cge => Error (msg "btest_for_compudz: Cge") + | Cle => Error (msg "btest_for_compudz: Cle") + | Cgt => Error (msg "btest_for_compudz: Cgt") + end. + +Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : + res basic := + if ireg_eq rd rs + then OK Pnop + else + (match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmove (btest_for_cmpswz cmp) rd rc rs)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + | Ccompl0 cmp => + OK (PArith (Pcmove (btest_for_cmpsdz cmp) rd rc rs)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + end). + Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -377,28 +418,6 @@ Definition transl_cond_op Error(msg "Asmblockgen.transl_cond_op") end. -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpuwz (c: comparison) := - match c with - | Cne => OK BTwnez - | Ceq => OK BTweqz - | Clt => Error (msg "btest_for_compuwz: Clt") - | Cge => Error (msg "btest_for_compuwz: Cge") - | Cle => Error (msg "btest_for_compuwz: Cle") - | Cgt => Error (msg "btest_for_compuwz: Cgt") - end. - -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpudz (c: comparison) := - match c with - | Cne => OK BTdnez - | Ceq => OK BTdeqz - | Clt => Error (msg "btest_for_compudz: Clt") - | Cge => Error (msg "btest_for_compudz: Cge") - | Cle => Error (msg "btest_for_compudz: Cle") - | Cgt => Error (msg "btest_for_compudz: Cgt") - end. - (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) @@ -821,6 +840,14 @@ Definition transl_op do rd <- ireg_of res; do rs <- ireg_of a1; OK (Pinsfl stop start rd rs ::i k) + | Osel cond0 ty, aT :: aF :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rF <- ireg_of aF; + do rC <- ireg_of aC; + do op <- conditional_move (negate_condition0 cond0) rC rT rF; + OK (op ::i k) + | _, _ => Error(msg "Asmgenblock.transl_op") end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8125741b..86e640c9 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1649,6 +1649,25 @@ Proof. destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. Qed. +Lemma select_same_lessdef: + forall ty c v, + Val.lessdef (Val.select c v v ty) v. +Proof. + intros. + unfold Val.select. + destruct c; try econstructor. + replace (if b then v else v) with v by (destruct b ; trivial). + destruct v; destruct ty; simpl; econstructor. +Qed. + +Lemma if_neg : forall X, + forall a, + forall b c : X, + (if (negb a) then b else c) = (if a then c else b). +Proof. + destruct a; reflexivity. +Qed. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1719,6 +1738,44 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. +- (* Osel *) + unfold conditional_move in *. + destruct (ireg_eq _ _). + { + subst x. inv EQ2. + econstructor; split. + { + apply exec_straight_one. + simpl. reflexivity. + } + split. + { apply select_same_lessdef. } + intros; trivial. + } + + destruct c0; simpl in *. + 1, 2, 3: + destruct c; simpl in *; inv EQ2; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + rewrite Pregmap.gss; + destruct (rs x1); simpl; trivial; + rewrite if_neg; + apply Val.lessdef_normalize. + + destruct c; simpl in *; inv EQ2; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + rewrite Pregmap.gss; + destruct (rs x1); simpl; trivial; + rewrite if_neg; + try apply Val.lessdef_normalize; + + destruct Archi.ptr64; simpl; replace (Int64.eq Int64.zero Int64.zero) with true by reflexivity; simpl; trivial; + destruct (_ || _); trivial; + apply Val.lessdef_normalize. Qed. (** Memory accesses *) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c7c04d83..be7ea812 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -301,90 +301,14 @@ Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) end. -Definition eval_selecti (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vint i0, Vint i1, Some bval => Vint (if bval then i1 else i0) - | _,_,_ => Vundef +Definition negate_condition0 (cond0 : condition0) : condition0 := + match cond0 with + | Ccomp0 c => Ccomp0 (negate_comparison c) + | Ccompu0 c => Ccompu0 (negate_comparison c) + | Ccompl0 c => Ccompl0 (negate_comparison c) + | Ccomplu0 c => Ccomplu0 (negate_comparison c) end. -Definition eval_selecti2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vint i0, Vint i1 => Vint (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selecti_to2: forall cond v0 v1 vselect m, - (eval_selecti cond v0 v1 vselect m) = - (eval_selecti2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selecti2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectl (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vlong i0, Vlong i1, Some bval => Vlong (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectl2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vlong i0, Vlong i1 => Vlong (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selectl_to2: forall cond v0 v1 vselect m, - (eval_selectl cond v0 v1 vselect m) = - (eval_selectl2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectl2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectf (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vfloat i0, Vfloat i1, Some bval => Vfloat (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectf2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vfloat i0, Vfloat i1 => Vfloat (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selectf_to2: forall cond v0 v1 vselect m, - (eval_selectf cond v0 v1 vselect m) = - (eval_selectf2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectf2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - -Definition eval_selectfs (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match v0, v1, (eval_condition0 cond vselect m) with - | Vsingle i0, Vsingle i1, Some bval => Vsingle (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Definition eval_selectfs2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val := - match (eval_condition0 cond vselect m), v0, v1 with - | Some bval, Vsingle i0, Vsingle i1 => Vsingle (if bval then i1 else i0) - | _,_,_ => Vundef - end. - -Lemma eval_selectfs_to2: forall cond v0 v1 vselect m, - (eval_selectfs cond v0 v1 vselect m) = - (eval_selectfs2 cond v0 v1 vselect m). -Proof. - intros. - unfold eval_selectfs2. - destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity. -Qed. - Definition eval_operation (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val) (m: mem): option val := -- cgit From 5feecb99712de3604f284e5934aed73f2b606659 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 11:47:14 +0200 Subject: start to have whole path if-conversion? --- mppa_k1c/SelectOp.vp | 5 ++++- mppa_k1c/SelectOpproof.v | 14 +++++++++++++- 2 files changed, 17 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 219a462b..ee614253 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,7 +66,10 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := None. +(** TODO *) +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := + Some (Eop (Osel (Ccomp0 Cne) ty) (e1 ::: e2 ::: + (Eop (Ocmp cond) args) ::: Enil)). (** ** Constants **) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 26f1bb89..7c6dfb7d 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1424,7 +1424,19 @@ Theorem eval_select: eval_expr ge sp e m le a v /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. Proof. - discriminate. + unfold select. + intros until b. + intro Hop; injection Hop; clear Hop; intro; subst a. + intros HeL He1 He2 HeC. + econstructor; split. + { + repeat (try econstructor; try eassumption). + } + apply Val.select_lessdef; trivial. + right. + rewrite HeC. + simpl. + destruct b; reflexivity. Qed. (* floating-point division *) -- cgit From 7c054b47cad2f75efa661b298484dfbfdd976701 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 13:03:38 +0200 Subject: little restructuring --- mppa_k1c/SelectOp.vp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index ee614253..8101a9b0 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -66,10 +66,11 @@ Section SELECT. Context {hf: helper_functions}. (** Ternary operator *) -(** TODO *) +Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := + (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). + Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := - Some (Eop (Osel (Ccomp0 Cne) ty) (e1 ::: e2 ::: - (Eop (Ocmp cond) args) ::: Enil)). + Some (select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args)). (** ** Constants **) -- cgit From 2facdc1ec4a51c0eeb31baa299677915e6155ed5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 18:04:47 +0200 Subject: why doesn't it work? --- mppa_k1c/SelectOp.vp | 44 ++++++++- mppa_k1c/SelectOpproof.v | 228 +++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 265 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 8101a9b0..f997d3d7 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -65,12 +65,54 @@ Section SELECT. Context {hf: helper_functions}. +Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := + match cond, args with + | (Ccomp c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 c), e1) + else None + | (Ccomp c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 (swap_comparison c)), e2) + else None + | (Ccompu c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 c), e1) + else None + | (Ccompu c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 (swap_comparison c)), e2) + else None + + | (Ccompl c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 c), e1) + else None + | (Ccompl c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 (swap_comparison c)), e2) + else None + | (Ccomplu c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 c), e1) + else None + | (Ccomplu c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 (swap_comparison c)), e2) + else None + | _, _ => None + end. + (** Ternary operator *) Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := - Some (select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args)). + Some( + match cond_to_condition0 cond args with + | None => select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args) + | Some(cond0, ec) => select0 ty cond0 e1 e2 ec + end). (** ** Constants **) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7c6dfb7d..47b4cbb3 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1412,6 +1412,98 @@ Proof. Qed. (* ternary *) +(* does not work due to possible nondeterminism +Lemma cond_to_condition0_correct : + forall cond : condition, + forall al : exprlist, + match (cond_to_condition0 cond al) with + | None => True + | Some(cond0, e1) => + forall le vl v1, + eval_expr ge sp e m le e1 v1 -> + eval_exprlist ge sp e m le al vl -> + (eval_condition0 cond0 v1 m) = (eval_condition cond vl m) + end. +Proof. + intros. + unfold cond_to_condition0. + case (cond_to_condition0_match cond al); trivial. + { + intros. + destruct (Int.eq_dec _ _); trivial. + intros until v1. + intros He1 Hel. + InvEval. + simpl. + f_equal. + eapply eval_expr_determ. eassumption. + } +Qed. +*) + +Lemma eval_select0: + forall le ty cond0 ac vc a1 v1 a2 v2, + eval_expr ge sp e m le ac vc -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + exists v, + eval_expr ge sp e m le (select0 ty cond0 a1 a2 ac) v + /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. +Proof. + intros. + econstructor; split. + { + unfold select0. + repeat (try econstructor; try eassumption). + } + constructor. +Qed. + +Lemma bool_cond0_ne: + forall ob : option bool, + forall m, + (eval_condition0 (Ccomp0 Cne) (Val.of_optbool ob) m) = ob. +Proof. + destruct ob; simpl; trivial. + intro. + destruct b; reflexivity. +Qed. + +Lemma eval_condition_ccomp_swap : + forall c x y m, + eval_condition (Ccomp (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomp c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmp_bool. +Qed. + +Lemma eval_condition_ccompu_swap : + forall c x y m, + eval_condition (Ccompu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpu_bool. +Qed. + +Lemma eval_condition_ccompl_swap : + forall c x y m, + eval_condition (Ccompl (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompl c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpl_bool. +Qed. + +Lemma eval_condition_ccomplu_swap : + forall c x y m, + eval_condition (Ccomplu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomplu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmplu_bool. +Qed. Theorem eval_select: forall le ty cond al vl a1 v1 a2 v2 a b, @@ -1428,15 +1520,139 @@ Proof. intros until b. intro Hop; injection Hop; clear Hop; intro; subst a. intros HeL He1 He2 HeC. - econstructor; split. + unfold cond_to_condition0. + destruct (cond_to_condition0_match cond al). { - repeat (try econstructor; try eassumption). + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmp_bool c v0 (Vint Int.zero)) + with (eval_condition0 (Ccomp0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). } - apply Val.select_lessdef; trivial. - right. - rewrite HeC. + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + rewrite <- eval_condition_ccomp_swap. + simpl. + change (Val.cmp_bool (swap_comparison c) v3 (Vint Int.zero)) + with (eval_condition0 (Ccomp0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccomp_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmp_bool (swap_comparison c) v3 (Vint x))). + rewrite Val.swap_cmp_bool. + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint Int.zero)) + with (eval_condition0 (Ccompu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + rewrite <- eval_condition_ccompu_swap. + simpl. + change (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 + (Vint Int.zero)) + with (eval_condition0 (Ccompu0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccompu_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vint x))). + rewrite Val.swap_cmpu_bool. + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmpl_bool c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccompl0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + rewrite <- eval_condition_ccompl_swap. + simpl. + change (Val.cmpl_bool (swap_comparison c) v3 (Vlong Int64.zero)) + with (eval_condition0 (Ccompl0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccompl_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmpl_bool (swap_comparison c) v3 (Vlong x))). + rewrite Val.swap_cmpl_bool. + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccomplu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + rewrite <- eval_condition_ccomplu_swap. + simpl. + change (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong Int64.zero)) + with (eval_condition0 (Ccomplu0 (swap_comparison c)) v3 m). + eapply eval_select0; eassumption. + } + rewrite <- eval_condition_ccomplu_swap. + simpl. + erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong x))). + rewrite Val.swap_cmplu_bool. + eapply eval_select0; repeat (try econstructor; try eassumption). + } + TrivialExists. + repeat (try econstructor; try eassumption). simpl. - destruct b; reflexivity. + f_equal. + rewrite HeC. + destruct b; simpl; reflexivity. Qed. (* floating-point division *) -- cgit From 74d93ac506f605a1c27179cb7acca2d033aca94b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 18:16:30 +0200 Subject: shortcut cmove works --- mppa_k1c/SelectOp.vp | 27 +++++-------------- mppa_k1c/SelectOpproof.v | 69 ------------------------------------------------ 2 files changed, 7 insertions(+), 89 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index f997d3d7..01985060 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -67,39 +67,26 @@ Context {hf: helper_functions}. Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := match cond, args with - | (Ccomp c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + | (Ccompimm c x), (e1 ::: Enil) => if Int.eq_dec x Int.zero then Some ((Ccomp0 c), e1) else None - | (Ccomp c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccomp0 (swap_comparison c)), e2) - else None - | (Ccompu c), (e1 ::: (Eop (Ointconst x) Enil) ::: Enil) => + + | (Ccompuimm c x), (e1 ::: Enil) => if Int.eq_dec x Int.zero then Some ((Ccompu0 c), e1) else None - | (Ccompu c), ((Eop (Ointconst x) Enil) ::: e2 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccompu0 (swap_comparison c)), e2) - else None - | (Ccompl c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + | (Ccomplimm c x), (e1 ::: Enil) => if Int64.eq_dec x Int64.zero then Some ((Ccompl0 c), e1) else None - | (Ccompl c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccompl0 (swap_comparison c)), e2) - else None - | (Ccomplu c), (e1 ::: (Eop (Olongconst x) Enil) ::: Enil) => + + | (Ccompluimm c x), (e1 ::: Enil) => if Int64.eq_dec x Int64.zero then Some ((Ccomplu0 c), e1) else None - | (Ccomplu c), ((Eop (Olongconst x) Enil) ::: e2 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccomplu0 (swap_comparison c)), e2) - else None + | _, _ => None end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 47b4cbb3..4047048c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1536,23 +1536,6 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - { - InvEval. - rewrite <- HeC. - destruct (Int.eq_dec x Int.zero). - { subst x. - rewrite <- eval_condition_ccomp_swap. - simpl. - change (Val.cmp_bool (swap_comparison c) v3 (Vint Int.zero)) - with (eval_condition0 (Ccomp0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccomp_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmp_bool (swap_comparison c) v3 (Vint x))). - rewrite Val.swap_cmp_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1567,24 +1550,6 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - { - InvEval. - rewrite <- HeC. - destruct (Int.eq_dec x Int.zero). - { subst x. - rewrite <- eval_condition_ccompu_swap. - simpl. - change (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 - (Vint Int.zero)) - with (eval_condition0 (Ccompu0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccompu_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vint x))). - rewrite Val.swap_cmpu_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1599,23 +1564,6 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - { - InvEval. - rewrite <- HeC. - destruct (Int64.eq_dec x Int64.zero). - { subst x. - rewrite <- eval_condition_ccompl_swap. - simpl. - change (Val.cmpl_bool (swap_comparison c) v3 (Vlong Int64.zero)) - with (eval_condition0 (Ccompl0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccompl_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmpl_bool (swap_comparison c) v3 (Vlong x))). - rewrite Val.swap_cmpl_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } { InvEval. rewrite <- HeC. @@ -1630,23 +1578,6 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - { - InvEval. - rewrite <- HeC. - destruct (Int64.eq_dec x Int64.zero). - { subst x. - rewrite <- eval_condition_ccomplu_swap. - simpl. - change (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong Int64.zero)) - with (eval_condition0 (Ccomplu0 (swap_comparison c)) v3 m). - eapply eval_select0; eassumption. - } - rewrite <- eval_condition_ccomplu_swap. - simpl. - erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) (swap_comparison c) v3 (Vlong x))). - rewrite Val.swap_cmplu_bool. - eapply eval_select0; repeat (try econstructor; try eassumption). - } TrivialExists. repeat (try econstructor; try eassumption). simpl. -- cgit From ed95a6a6fbdd915e361e696d4bf72e5a545b965e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 20:00:47 +0200 Subject: shortcuts for cmove --- mppa_k1c/Asmblockgen.v | 8 +++---- mppa_k1c/Asmblockgenproof1.v | 52 ++++++++++++++++++++++++++++++-------------- 2 files changed, 40 insertions(+), 20 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 72d7394b..04ce13e7 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -342,8 +342,8 @@ Definition btest_for_cmpuwz (c: comparison) := | Ceq => OK BTweqz | Clt => Error (msg "btest_for_compuwz: Clt") | Cge => Error (msg "btest_for_compuwz: Cge") - | Cle => Error (msg "btest_for_compuwz: Cle") - | Cgt => Error (msg "btest_for_compuwz: Cgt") + | Cle => OK BTweqz + | Cgt => OK BTwnez end. (* CoMPare Unsigned Words to Zero *) @@ -353,8 +353,8 @@ Definition btest_for_cmpudz (c: comparison) := | Ceq => OK BTdeqz | Clt => Error (msg "btest_for_compudz: Clt") | Cge => Error (msg "btest_for_compudz: Cge") - | Cle => Error (msg "btest_for_compudz: Cle") - | Cgt => Error (msg "btest_for_compudz: Cgt") + | Cle => OK BTdeqz + | Cgt => OK BTdnez end. Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 86e640c9..1ed584e8 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1668,6 +1668,30 @@ Proof. destruct a; reflexivity. Qed. +Lemma int_ltu_to_neq: + forall x, + Int.ltu Int.zero x = negb (Int.eq x Int.zero). +Proof. + intros. + unfold Int.ltu, Int.eq. + change (Int.unsigned Int.zero) with 0. + pose proof (Int.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + +Lemma int64_ltu_to_neq: + forall x, + Int64.ltu Int64.zero x = negb (Int64.eq x Int64.zero). +Proof. + intros. + unfold Int64.ltu, Int64.eq. + change (Int64.unsigned Int64.zero) with 0. + pose proof (Int64.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1754,28 +1778,24 @@ Opaque Int.eq. } destruct c0; simpl in *. - 1, 2, 3: - destruct c; simpl in *; inv EQ2; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - rewrite Pregmap.gss; - destruct (rs x1); simpl; trivial; - rewrite if_neg; - apply Val.lessdef_normalize. - + + all: destruct c; simpl in *; inv EQ2; econstructor; split; try (apply exec_straight_one; constructor); split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); unfold Val.select; simpl; rewrite Pregmap.gss; destruct (rs x1); simpl; trivial; - rewrite if_neg; - try apply Val.lessdef_normalize; - - destruct Archi.ptr64; simpl; replace (Int64.eq Int64.zero Int64.zero) with true by reflexivity; simpl; trivial; - destruct (_ || _); trivial; - apply Val.lessdef_normalize. + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. Qed. (** Memory accesses *) -- cgit From ac366a59308ae85a0cbfefb8b9be79763d5c5f91 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 21:16:40 +0200 Subject: added immediate cmove --- mppa_k1c/Asm.v | 9 ++++- mppa_k1c/Asmblockdeps.v | 4 ++ mppa_k1c/Asmblockgenproof1.v | 3 ++ mppa_k1c/Asmvliw.v | 76 +++++++++++++++++++++--------------- mppa_k1c/PostpassSchedulingOracle.ml | 20 +++++++--- mppa_k1c/TargetPrinter.ml | 6 +++ 6 files changed, 80 insertions(+), 38 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e5f81fbb..620aa91e 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -273,6 +273,10 @@ Inductive instruction : Type := | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) . (** Correspondance between Asmblock and Asm *) @@ -447,10 +451,13 @@ Definition basic_to_instruction (b: basic) := (** ARRI32 *) | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm (** ARRI64 *) | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm (** Load *) | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 616ec6db..265c4e84 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1515,11 +1515,15 @@ Definition string_of_name_arr (n: arith_name_arr): pstring := Definition string_of_name_arri32 (n: arith_name_arri32): pstring := match n with | Pmaddiw => "Pmaddw" + | Pcmoveiw _ => "Pcmoveiw" + | Pcmoveuiw _ => "Pcmoveuiw" end. Definition string_of_name_arri64 (n: arith_name_arri64): pstring := match n with | Pmaddil => "Pmaddl" + | Pcmoveil _ => "Pcmoveil" + | Pcmoveuil _ => "Pcmoveuil" end. Definition string_of_arith (op: arith_op): pstring := diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 1ed584e8..8939cc30 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1759,9 +1759,11 @@ Opaque Int.eq. destruct (Int.ltu _ _); simpl; trivial. * intros. rewrite Pregmap.gso; trivial. + - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). exists rs'; split. eexact A. eauto with asmgen. + - (* Osel *) unfold conditional_move in *. destruct (ireg_eq _ _). @@ -1784,6 +1786,7 @@ Opaque Int.eq. econstructor; split; try (apply exec_straight_one; constructor); split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); unfold Val.select; simpl; + unfold cmove, cmoveu; rewrite Pregmap.gss; destruct (rs x1); simpl; trivial; try rewrite int_ltu_to_neq; diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 886228ad..bb6b7132 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -527,10 +527,14 @@ Inductive arith_name_arrr : Type := Inductive arith_name_arri32 : Type := | Pmaddiw (**r multiply add word *) + | Pcmoveiw (bt: btest) + | Pcmoveuiw (bt: btest) . Inductive arith_name_arri64 : Type := | Pmaddil (**r multiply add long *) + | Pcmoveil (bt: btest) + | Pcmoveuil (bt: btest) . Inductive arith_name_arr : Type := @@ -1120,44 +1124,48 @@ Definition arith_eval_rri64 n v i := | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i) end. +Definition cmove bt v1 v2 v3 := + match cmp_for_btest bt with + | (Some c, Int) => + match Val.cmp_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val.cmpl_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef + end. + +Definition cmoveu bt v1 v2 v3 := + match cmpu_for_btest bt with + | (Some c, Int) => + match Val_cmpu_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val_cmplu_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef + end. + Definition arith_eval_arrr n v1 v2 v3 := match n with | Pmaddw => Val.add v1 (Val.mul v2 v3) | Pmaddl => Val.addl v1 (Val.mull v2 v3) | Pmsubw => Val.sub v1 (Val.mul v2 v3) | Pmsubl => Val.subl v1 (Val.mull v2 v3) - | Pcmove bt => - match cmp_for_btest bt with - | (Some c, Int) => - match Val.cmp_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val.cmpl_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end - | Pcmoveu bt => - match cmpu_for_btest bt with - | (Some c, Int) => - match Val_cmpu_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val_cmplu_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end + | Pcmove bt => cmove bt v1 v2 v3 + | Pcmoveu bt => cmoveu bt v1 v2 v3 end. Definition arith_eval_arr n v1 v2 := @@ -1169,11 +1177,15 @@ Definition arith_eval_arr n v1 v2 := Definition arith_eval_arri32 n v1 v2 v3 := match n with | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) + | Pcmoveiw bt => cmove bt v1 v2 (Vint v3) + | Pcmoveuiw bt => cmoveu bt v1 v2 (Vint v3) end. Definition arith_eval_arri64 n v1 v2 v3 := match n with | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) + | Pcmoveil bt => cmove bt v1 v2 (Vlong v3) + | Pcmoveuil bt => cmoveu bt v1 v2 (Vlong v3) end. Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index af1e8f85..78af896a 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -154,7 +154,17 @@ let arith_arrr_str = function | Pmsubl -> "Pmsubl" | Pcmove _ -> "Pcmove" | Pcmoveu _ -> "Pcmoveu" - + +let arith_arri32_str = function + | Pmaddiw -> "Pmaddiw" + | Pcmoveiw _ -> "Pcmoveiw" + | Pcmoveuiw _ -> "Pcmoveuiw" + +let arith_arri64_str = function + | Pmaddil -> "Pmaddil" + | Pcmoveil _ -> "Pcmoveil" + | Pcmoveuil _ -> "Pcmoveuil" + let arith_ri32_str = "Pmake" let arith_ri64_str = "Pmakel" @@ -194,9 +204,9 @@ let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Re let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false} -let arith_arri32_rec i rd rs imm32 = { inst = "Pmaddiw"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } +let arith_arri32_rec i rd rs imm32 = { inst = arith_arri32_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } -let arith_arri64_rec i rd rs imm64 = { inst = "Pmaddil"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } +let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } let arith_arr_rec i rd rs = { inst = arith_arr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false} @@ -215,8 +225,8 @@ let arith_rec i = | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) | PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs) (* Seems like single constant constructor types are elided *) - | PArithARRI32 ((* i,*) rd, rs, imm32) -> arith_arri32_rec () (IR rd) (IR rs) (Some (I32 imm32)) - | PArithARRI64 ((* i,*) rd, rs, imm64) -> arith_arri64_rec () (IR rd) (IR rs) (Some (I64 imm64)) + | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) + | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) | PArithRI32 (rd, imm32) -> { inst = arith_ri32_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 34765726..8365d54f 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -717,6 +717,12 @@ module Target (*: TARGET*) = | Pcmove (bt, rd, rcond, rs) | Pcmoveu (bt, rd, rcond, rs) -> fprintf oc " cmoved.%a %a? %a = %a\n" bcond bt ireg rcond ireg rd ireg rs + | Pcmoveiw (bt, rd, rcond, imm) | Pcmoveuiw (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint imm + | Pcmoveil (bt, rd, rcond, imm) | Pcmoveuil (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint64 imm let get_section_names name = let (text, lit) = -- cgit From 6064bac57701ba0a12031d43acbe25cb0140730c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 21:42:30 +0200 Subject: begin osel imm --- mppa_k1c/NeedOp.v | 12 ++++++++++++ mppa_k1c/Op.v | 42 +++++++++++++++++++++++++++++++++++++++--- mppa_k1c/ValueAOp.v | 6 ++++++ 3 files changed, 57 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 047c180a..4748f38b 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -133,6 +133,8 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) | Osel c ty => nv :: nv :: needs_of_condition0 c + | Oselimm c imm + | Osellimm c imm => nv :: needs_of_condition0 c end. Definition operation_is_redundant (op: operation) (nv: nval): bool := @@ -347,6 +349,16 @@ Proof. erewrite needs_of_condition0_sound by eauto. apply select_sound; auto. simpl; auto with na. + (* select imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. + (* select long imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. Qed. Lemma operation_is_redundant_sound: diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index be7ea812..1b3a839f 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -210,7 +210,9 @@ Inductive operation : Type := | Oextfsl (stop : Z) (start : Z) | Oinsf (stop : Z) (start : Z) | Oinsfl (stop : Z) (start : Z) - | Osel (c0 : condition0) (ty : typ). + | Osel (c0 : condition0) (ty : typ) + | Oselimm (c0 : condition0) (imm: int) + | Osellimm (c0 : condition0) (imm: int64). (** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *) @@ -454,6 +456,8 @@ Definition eval_operation | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) + | Oselimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) + | Osellimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) | _, _ => None end. @@ -658,6 +662,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oinsf _ _ => (Tint :: Tint :: nil, Tint) | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) + | Oselimm c ty => (Tint :: Tint :: arg_type_of_condition0 c :: nil, Tint) + | Osellimm c ty => (Tlong :: Tlong :: arg_type_of_condition0 c :: nil, Tlong) end. (* FIXME: two Tptr ?! *) @@ -971,6 +977,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - unfold Val.select. destruct (eval_condition0 _ _ m). + apply Val.normalize_type. + constructor. + (* Oselimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. + (* Osellimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. Qed. End SOUNDNESS. @@ -1132,8 +1146,8 @@ Definition op_depends_on_memory (op: operation) : bool := | Ocmp (Ccomplu _) => Archi.ptr64 | Ocmp (Ccompluimm _ _) => Archi.ptr64 - | Osel (Ccompu0 _) _ => negb Archi.ptr64 - | Osel (Ccomplu0 _) _ => Archi.ptr64 + | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64 | _ => false end. @@ -1150,6 +1164,12 @@ Proof. - destruct c0; simpl; try congruence; intros SF; auto; rewrite ? negb_false_iff in SF; unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1591,6 +1611,22 @@ Proof. symmetry. eapply eval_condition0_inj; eassumption. + left. trivial. + + (* Oselimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Osellimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. Qed. Lemma eval_addressing_inj: diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index d24cebcc..daceab8b 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -265,6 +265,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 + | Oselimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) + | Osellimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) | _, _ => Vbot end. @@ -421,6 +423,10 @@ Proof. + constructor. (* select *) - apply select_sound; auto. eapply eval_static_condition0_sound; eauto. + (* select imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. + (* select long imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. Qed. End SOUNDNESS. -- cgit From 68a6d0dd0ea5774529d823fb9a9ca981c1ecebb0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 22:58:34 +0200 Subject: osel imm --- mppa_k1c/Asmblockgen.v | 43 ++++++++++++++++++++++++++++++++ mppa_k1c/Asmblockgenproof1.v | 48 ++++++++++++++++++++++++++++++++++++ mppa_k1c/Machregs.v | 2 +- mppa_k1c/Op.v | 12 ++++----- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- mppa_k1c/SelectOp.vp | 10 ++++++-- mppa_k1c/SelectOpproof.v | 19 ++++++-------- mppa_k1c/ValueAOp.v | 4 +-- 8 files changed, 117 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 04ce13e7..e5b9b35a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -375,6 +375,34 @@ Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : OK (PArith (Pcmoveu bt rd rc rs)) end). +Definition conditional_move_imm32 (cond0 : condition0) (rc rd : ireg) (imm : int) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + end. + +Definition conditional_move_imm64 (cond0 : condition0) (rc rd : ireg) (imm : int64) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + end. + Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := match cond, args with @@ -847,6 +875,21 @@ Definition transl_op do rC <- ireg_of aC; do op <- conditional_move (negate_condition0 cond0) rC rT rF; OK (op ::i k) + + | Oselimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm32 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) + + + | Osellimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm64 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) | _, _ => Error(msg "Asmgenblock.transl_op") diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 8939cc30..bc549b4a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1799,6 +1799,54 @@ Opaque Int.eq. try destruct (_ || _); trivial; try apply Val.lessdef_normalize. + +- (* Oselimm *) + unfold conditional_move_imm32 in *. + destruct c0; simpl in *. + + all: + destruct c; simpl in *; inv EQ0; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + unfold cmove, cmoveu; + rewrite Pregmap.gss; + destruct (rs x0); simpl; trivial; + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. + + +- (* Osellimm *) + unfold conditional_move_imm64 in *. + destruct c0; simpl in *. + + all: + destruct c; simpl in *; inv EQ0; + econstructor; split; try (apply exec_straight_one; constructor); + split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); + unfold Val.select; simpl; + unfold cmove, cmoveu; + rewrite Pregmap.gss; + destruct (rs x0); simpl; trivial; + try rewrite int_ltu_to_neq; + try rewrite int64_ltu_to_neq; + try change (Int64.eq Int64.zero Int64.zero) with true; + try destruct Archi.ptr64; + repeat rewrite if_neg; + simpl; + trivial; + try destruct (_ || _); + trivial; + try apply Val.lessdef_normalize. + Qed. (** Memory accesses *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index ee3a63c7..5a7d42b4 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -216,7 +216,7 @@ Definition two_address_op (op: operation) : bool := | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl - | Osel _ _ + | Osel _ _ | Oselimm _ _ | Osellimm _ _ | Oinsf _ _ | Oinsfl _ _ => true | _ => false end. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 1b3a839f..35fbb596 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -456,8 +456,8 @@ Definition eval_operation | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) - | Oselimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) - | Osellimm c imm, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) + | Oselimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) + | Osellimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) | _, _ => None end. @@ -662,8 +662,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Oinsf _ _ => (Tint :: Tint :: nil, Tint) | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) - | Oselimm c ty => (Tint :: Tint :: arg_type_of_condition0 c :: nil, Tint) - | Osellimm c ty => (Tlong :: Tlong :: arg_type_of_condition0 c :: nil, Tlong) + | Oselimm c ty => (Tint :: arg_type_of_condition0 c :: nil, Tint) + | Osellimm c ty => (Tlong :: arg_type_of_condition0 c :: nil, Tlong) end. (* FIXME: two Tptr ?! *) @@ -1614,7 +1614,7 @@ Proof. (* Oselimm *) - apply Val.select_inject; trivial. - destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + destruct (eval_condition0 _ _ _) eqn:Hcond. + right. symmetry. eapply eval_condition0_inj; eassumption. @@ -1622,7 +1622,7 @@ Proof. (* Osellimm *) - apply Val.select_inject; trivial. - destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + destruct (eval_condition0 _ _ _) eqn:Hcond. + right. symmetry. eapply eval_condition0_inj; eassumption. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 78af896a..6ccc4e97 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -551,7 +551,7 @@ let ab_inst_to_real = function | "Pfixedudrzz" -> Fixedudz | "Pfixeddrzz_i32" -> Fixeddz | "Pfixedudrzz_i32" -> Fixedudz - | "Pcmove" | "Pcmoveu" -> Cmoved + | "Pcmove" | "Pcmoveu" | "Pcmoveiw" | "Pcmoveuiw" | "Pcmoveil" | "Pcmoveuil" -> Cmoved | "Plb" -> Lbs | "Plbu" -> Lbz diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 01985060..2618983b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -91,8 +91,14 @@ Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := end. (** Ternary operator *) -Definition select0 (ty : typ) (cond0 : condition0) (e1 e2 eC: expr) := - (Eop (Osel cond0 ty) (e1 ::: e2 ::: eC ::: Enil)). +Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) := + match ty, cond0, e1, e2, e3 with + | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 => + (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => + (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil)) + | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil)) + end. Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := Some( diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 4047048c..39ad763e 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1451,12 +1451,10 @@ Lemma eval_select0: /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. Proof. intros. - econstructor; split. - { - unfold select0. - repeat (try econstructor; try eassumption). - } - constructor. + unfold select0. + destruct (select0_match ty cond0 a1 a2 ac). + all: InvEval; econstructor; split; + repeat (try econstructor; try eassumption). Qed. Lemma bool_cond0_ne: @@ -1578,12 +1576,11 @@ Proof. erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). eapply eval_select0; repeat (try econstructor; try eassumption). } - TrivialExists. - repeat (try econstructor; try eassumption). + erewrite <- (bool_cond0_ne (Some b)). + eapply eval_select0; repeat (try econstructor; try eassumption). + rewrite <- HeC. simpl. - f_equal. - rewrite HeC. - destruct b; simpl; reflexivity. + reflexivity. Qed. (* floating-point division *) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index daceab8b..439138da 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -265,8 +265,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 - | Oselimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) - | Osellimm c imm, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) + | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) + | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) | _, _ => Vbot end. -- cgit From b5352b040da8c38b371316d67c2180dbab758295 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 4 Jun 2019 23:16:35 +0200 Subject: move with immediates --- mppa_k1c/SelectOp.vp | 4 ++++ mppa_k1c/SelectOpproof.v | 28 +++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 2618983b..3df0c682 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -95,8 +95,12 @@ Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) := match ty, cond0, e1, e2, e3 with | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 => (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tint, cond0, (Eop (Ointconst imm) Enil), e2, e3 => + (Eop (Oselimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tlong, cond0, (Eop (Olongconst imm) Enil), e2, e3 => + (Eop (Osellimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil)) end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 39ad763e..21a06857 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1441,6 +1441,31 @@ Proof. Qed. *) +Lemma eval_neg_condition0: + forall cond0: condition0, + forall v1: val, + forall m: mem, + (eval_condition0 (negate_condition0 cond0) v1 m) = + option_map negb (eval_condition0 cond0 v1 m). +Proof. + intros. + destruct cond0; simpl; + try rewrite Val.negate_cmp_bool; + try rewrite Val.negate_cmpu_bool; + try rewrite Val.negate_cmpl_bool; + try rewrite Val.negate_cmplu_bool; + reflexivity. +Qed. + +Lemma select_neg: + forall a b c, + Val.select (option_map negb a) b c = + Val.select a c b. +Proof. + destruct a; simpl; trivial. + destruct b; simpl; trivial. +Qed. + Lemma eval_select0: forall le ty cond0 ac vc a1 v1 a2 v2, eval_expr ge sp e m le ac vc -> @@ -1454,7 +1479,8 @@ Proof. unfold select0. destruct (select0_match ty cond0 a1 a2 ac). all: InvEval; econstructor; split; - repeat (try econstructor; try eassumption). + try repeat (try econstructor; try eassumption). + all: rewrite eval_neg_condition0; rewrite select_neg; constructor. Qed. Lemma bool_cond0_ne: -- cgit From 72288298ea871d30db6693a65fe0ac2236a045c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 5 Jun 2019 09:45:07 +0200 Subject: fixed reservation table for cmove --- mppa_k1c/PostpassSchedulingOracle.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 6ccc4e97..3924000b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -607,10 +607,14 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd | Cmoved -> + | Nxord | Andnd | Ornd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y) + |Cmoved -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) | Addxw -> (match encoding with None | Some U6 | Some S10 -> alu_lite | Some U27L5 | Some U27L10 -> alu_lite_x -- cgit From 45844ce2210b58ddc29a2bcd55e3e0ddbe208ed0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 5 Jun 2019 14:14:36 +0200 Subject: Fix for #134 Pjumptable not recognized --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 3924000b..2fc561ee 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -291,7 +291,7 @@ let ctl_flow_rec = function | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None ; is_control = true} | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pjumptable (r, _) -> { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} + | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) let control_rec i = match i with -- cgit From 8f88967df89f625d1a15f4c36f49450fe42e97db Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 8 Jun 2019 22:09:55 +0200 Subject: abstract_bb: few improvements while writing the paper --- mppa_k1c/abstractbb/ImpSimuTest.v | 236 ++++++++++++------ mppa_k1c/abstractbb/Impure/ImpHCons.v | 18 +- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 6 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 8 +- .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 2 +- mppa_k1c/abstractbb/SeqSimuTheory.v | 275 +++++++++------------ 6 files changed, 294 insertions(+), 251 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 8f6b05b7..ea55b735 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -44,7 +44,32 @@ End ISeqLanguage. Module Type ImpDict. -Include PseudoRegDictionary. +Declare Module R: PseudoRegisters. + +Parameter t: Type -> Type. + +Parameter get: forall {A}, t A -> R.t -> option A. + +Parameter set: forall {A}, t A -> R.t -> A -> t A. + +Parameter set_spec_eq: forall A d x (v: A), + get (set d x v) x = Some v. + +Parameter set_spec_diff: forall A d x y (v: A), + x <> y -> get (set d x v) y = get d y. + +Parameter rem: forall {A}, t A -> R.t -> t A. + +Parameter rem_spec_eq: forall A (d: t A) x, + get (rem d x) x = None. + +Parameter rem_spec_diff: forall A (d: t A) x y, + x <> y -> get (rem d x) y = get d y. + +Parameter empty: forall {A}, t A. + +Parameter empty_spec: forall A x, + get (empty (A:=A)) x = None. Parameter eq_test: forall {A}, t A -> t A -> ?? bool. @@ -95,9 +120,10 @@ Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuI Module CoreL:=L. -Module ST := SimuTheory L Dict. +Module ST := SimuTheory L. Import ST. +Import Terms. Definition term_set_hid (t: term) (hid: hashcode): term := match t with @@ -212,9 +238,14 @@ Hint Resolve hLTcons_correct: wlp. (* Second, we use these hashed constructors ! *) -Record hsmem:= {hpre: list term; hpost: Dict.t term}. +Record hsmem:= {hpre: list term; hpost:> Dict.t term}. -Coercion hpost: hsmem >-> Dict.t. +(** evaluation of the post-condition *) +Definition hsmem_post_eval ge (hd: Dict.t term) x (m:mem) := + match Dict.get hd x with + | None => Some (m x) + | Some ht => term_eval ge ht m + end. Definition hsmem_get (d:hsmem) x: ?? term := match Dict.get d x with @@ -223,9 +254,9 @@ Definition hsmem_get (d:hsmem) x: ?? term := end. Lemma hsmem_get_correct (d:hsmem) x: - WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = smem_eval ge d x m. + WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = hsmem_post_eval ge d x m. Proof. - unfold hsmem_get, smem_eval, smem_get; destruct (Dict.get d x); wlp_simplify. + unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify. Qed. Global Opaque hsmem_get. Hint Resolve hsmem_get_correct: wlp. @@ -234,17 +265,17 @@ Local Opaque allvalid. Definition smem_model ge (d: smem) (hd:hsmem): Prop := (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) - /\ (forall m x, smem_valid ge d m -> smem_eval ge hd x m = (smem_eval ge d x m)). + /\ (forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m = (ST.term_eval ge (d x) m)). Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> - forall m x, smem_valid ge d m -> smem_eval ge hd x m <> None. + forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m <> None. Proof. intros (H1 & H2) m x H. rewrite H2; auto. unfold smem_valid in H. intuition eauto. Qed. Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> - forall m x, allvalid ge hd.(hpre) m -> smem_eval ge hd x m <> None. + forall m x, allvalid ge hd.(hpre) m -> hsmem_post_eval ge hd x m <> None. Proof. intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. - split; eauto. @@ -256,14 +287,14 @@ Definition naive_set (hd:hsmem) x (t:term) := Lemma naive_set_correct hd x ht ge d t: smem_model ge d hd -> - (forall m, smem_valid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> smem_model ge (smem_set d x t) (naive_set hd x ht). Proof. unfold naive_set; intros (DM0 & DM1) EQT; split. - intros m. destruct (DM0 m) as (PRE & VALID0); clear DM0. assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } - assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, smem_eval ge d x m <> None). { unfold smem_valid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, ST.term_eval ge (d x) m <> None). { unfold smem_valid in PRE; tauto. } rewrite !allvalid_extensionality in * |- *; simpl. intuition (subst; eauto). + eapply smem_valid_set_proof; eauto. @@ -272,7 +303,7 @@ Proof. intros X1; exploit smem_valid_set_decompose_2; eauto. rewrite <- EQT; eauto. + exploit smem_valid_set_decompose_1; eauto. - - clear DM0. unfold smem_eval, smem_eval, smem_get in * |- *; simpl. + - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. Local Hint Resolve smem_valid_set_decompose_1. intros; case (R.eq_dec x x0). + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. @@ -282,7 +313,7 @@ Local Hint Resolve naive_set_correct. Definition equiv_hsmem ge (hd1 hd2: hsmem) := (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) - /\ (forall m x, allvalid ge hd1.(hpre) m -> smem_eval ge hd1 x m = smem_eval ge hd2 x m). + /\ (forall m x, allvalid ge hd1.(hpre) m -> hsmem_post_eval ge hd1 x m = hsmem_post_eval ge hd2 x m). Lemma equiv_smem_symmetry ge hd1 hd2: equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1. @@ -363,11 +394,9 @@ Global Opaque hterm_append. Definition smart_set (hd:hsmem) x (ht:term) := match ht with - | Input _ _ => - DO ot <~ hsmem_get hd x;; - DO b <~ phys_eq ot ht;; - if b then - RET (hd.(hpost)) + | Input y _ => + if R.eq_dec x y then + RET (Dict.rem hd x) else ( log_assign x ht;; RET (Dict.set hd x ht) @@ -379,12 +408,12 @@ Definition smart_set (hd:hsmem) x (ht:term) := Lemma smart_set_correct hd x ht: WHEN smart_set hd x ht ~> d THEN - forall ge m y, smem_eval ge d y m = smem_eval ge (Dict.set hd x ht) y m. + forall ge m y, hsmem_post_eval ge d y m = hsmem_post_eval ge (Dict.set hd x ht) y m. Proof. destruct ht; wlp_simplify. - unfold smem_eval at 2; unfold smem_get; simpl; case (R.eq_dec x y). - - intros; subst. rewrite Dict.set_spec_eq. congruence. - - intros; rewrite Dict.set_spec_diff; auto. + unfold hsmem_post_eval; simpl. case (R.eq_dec x0 y). + - intros; subst. rewrite Dict.set_spec_eq, Dict.rem_spec_eq. simpl; congruence. + - intros; rewrite Dict.set_spec_diff, Dict.rem_spec_diff; auto. Qed. (*Local Hint Resolve smart_set_correct: wlp.*) Global Opaque smart_set. @@ -400,7 +429,7 @@ Definition hsmem_set (hd:hsmem) x (t:term) := Lemma hsmem_set_correct hd x ht: WHEN hsmem_set hd x ht ~> nhd THEN forall ge d t, smem_model ge d hd -> - (forall m, smem_valid ge d m -> term_eval ge ht m = term_eval ge t m) -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> smem_model ge (smem_set d x t) nhd. Proof. intros; wlp_simplify. @@ -414,9 +443,9 @@ Proof. - intros m x0 ALLVALID; rewrite SMART. destruct (term_eval ge ht m) eqn: Hht. * case (R.eq_dec x x0). - + intros; subst. unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_eq. + + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq. erewrite LIFT, EFFECT; eauto. - + intros; unfold smem_eval; unfold smem_get; simpl. rewrite !Dict.set_spec_diff; auto. + + intros; unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_diff; auto. * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. Qed. Local Hint Resolve hsmem_set_correct: wlp. @@ -439,53 +468,53 @@ Qed. Local Hint Resolve exp_hterm_correct: wlp. *) -Fixpoint hexp_term (e: exp) (d od: hsmem): ?? term := +Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term := match e with - | PReg x => hsmem_get d x + | PReg x => hsmem_get hd x | Op o le => - DO lt <~ hlist_exp_term le d od;; + DO lt <~ list_exp_hterm le hd hod;; hApp o lt - | Old e => hexp_term e od od + | Old e => exp_hterm e hod hod end -with hlist_exp_term (le: list_exp) (d od: hsmem): ?? list_term := +with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term := match le with | Enil => hLTnil tt | Econs e le' => - DO t <~ hexp_term e d od;; - DO lt <~ hlist_exp_term le' d od;; + DO t <~ exp_hterm e hd hod;; + DO lt <~ list_exp_hterm le' hd hod;; hLTcons t lt - | LOld le => hlist_exp_term le od od + | LOld le => list_exp_hterm le hod hod end. -Lemma hexp_term_correct_x ge e hod od: +Lemma exp_hterm_correct_x ge e hod od: smem_model ge od hod -> forall hd d, smem_model ge d hd -> - WHEN hexp_term e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = term_eval ge (exp_term e d od) m. + WHEN exp_hterm e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. Proof. intro H. induction e using exp_mut with (P0:=fun le => forall d hd, smem_model ge d hd -> - WHEN hlist_exp_term le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = list_term_eval ge (list_exp_term le d od) m); - unfold smem_model, smem_eval in * |- * ; simpl; wlp_simplify. + WHEN list_exp_hterm le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = ST.list_term_eval ge (list_exp_term le d od) m); + unfold smem_model, hsmem_post_eval in * |- * ; simpl; wlp_simplify. - rewrite H1, <- H4; auto. - rewrite H4, <- H0; simpl; auto. - rewrite H5, <- H0, <- H4; simpl; auto. Qed. -Global Opaque hexp_term. +Global Opaque exp_hterm. -Lemma hexp_term_correct e hd hod: - WHEN hexp_term e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = term_eval ge (exp_term e d od) m. +Lemma exp_hterm_correct e hd hod: + WHEN exp_hterm e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. Proof. - unfold wlp; intros; eapply hexp_term_correct_x; eauto. + unfold wlp; intros; eapply exp_hterm_correct_x; eauto. Qed. -Hint Resolve hexp_term_correct: wlp. +Hint Resolve exp_hterm_correct: wlp. Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := match i with | nil => RET hd | (x, e)::i' => - DO ht <~ hexp_term e hd hod;; + DO ht <~ exp_hterm e hd hod;; DO nd <~ hsmem_set hd x ht;; hinst_smem i' nd hod end. @@ -503,37 +532,41 @@ Local Hint Resolve hinst_smem_correct: wlp. (* logging info: we log the number of inst-instructions passed ! *) Variable log_new_inst: unit -> ?? unit. -Fixpoint hbblock_smem_rec (p: bblock) (d: hsmem): ?? hsmem := +Fixpoint bblock_hsmem_rec (p: bblock) (d: hsmem): ?? hsmem := match p with | nil => RET d | i::p' => log_new_inst tt;; DO d' <~ hinst_smem i d d;; - hbblock_smem_rec p' d' + bblock_hsmem_rec p' d' end. -Lemma hbblock_smem_rec_correct p: forall hd, - WHEN hbblock_smem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. +Lemma bblock_hsmem_rec_correct p: forall hd, + WHEN bblock_hsmem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. Proof. induction p; simpl; wlp_simplify. Qed. -Global Opaque hbblock_smem_rec. -Local Hint Resolve hbblock_smem_rec_correct: wlp. +Global Opaque bblock_hsmem_rec. +Local Hint Resolve bblock_hsmem_rec_correct: wlp. +Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}. -Definition hbblock_smem: bblock -> ?? hsmem - := fun p => hbblock_smem_rec p {| hpre:= nil ; hpost := Dict.empty |}. +Lemma hsmem_empty_correct ge: smem_model ge smem_empty hsmem_empty. +Proof. + unfold smem_model, smem_valid, hsmem_post_eval; simpl; intuition try congruence. + rewrite !Dict.empty_spec; simpl; auto. +Qed. -Transparent allvalid. +Definition bblock_hsmem: bblock -> ?? hsmem + := fun p => bblock_hsmem_rec p hsmem_empty. -Lemma hbblock_smem_correct p: - WHEN hbblock_smem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Lemma bblock_hsmem_correct p: + WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. - unfold bblock_smem; wlp_simplify. eapply H. clear H. - unfold smem_model, smem_valid, smem_eval, smem_get; simpl; intuition; - rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence. + Local Hint Resolve hsmem_empty_correct. + wlp_simplify. Qed. -Global Opaque hbblock_smem. +Global Opaque bblock_hsmem. End CanonBuilding. @@ -586,13 +619,13 @@ Qed. Global Opaque list_term_hash_eq. Hint Resolve list_term_hash_eq_correct: wlp. -Lemma smem_eval_intro (d1 d2: hsmem): - (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, smem_eval ge d1 x m = smem_eval ge d2 x m). +Lemma hsmem_post_eval_intro (d1 d2: hsmem): + (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, hsmem_post_eval ge d1 x m = hsmem_post_eval ge d2 x m). Proof. - unfold smem_eval, smem_get; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. + unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. Qed. -Local Hint Resolve hbblock_smem_correct Dict.eq_test_correct: wlp. +Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp. Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := {| @@ -629,9 +662,9 @@ Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := DO failure_in_failpreserv <~ make_cref false;; DO r <~ (TRY - DO d1 <~ hbblock_smem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; + DO d1 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; DO log_new_term <~ log_new_term hco_term hco_list;; - DO d2 <~ hbblock_smem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; + DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; DO b <~ Dict.eq_test d1 d2 ;; if b then ( if check_failpreserv then ( @@ -653,12 +686,12 @@ Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := Obligation 1. constructor 1; wlp_simplify; try congruence. destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. - apply bblock_smem_simu; auto. + apply bblock_smem_simu; auto. split. + intros m; rewrite <- EQPRE1, <- EQPRE2. rewrite ! allvalid_extensionality. unfold incl in * |- *; intuition eauto. - + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto. - erewrite smem_eval_intro; eauto. + + intros m0 x VALID; rewrite <- EQPOST1, <- EQPOST2; auto. + erewrite hsmem_post_eval_intro; eauto. erewrite <- EQPRE2; auto. erewrite <- EQPRE1 in VALID. rewrite ! allvalid_extensionality in * |- *. @@ -677,8 +710,8 @@ End Prog_Eq_Gen. -Definition hht: hashH term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. -Definition hlht: hashH list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. +Definition hpt: hashP term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. +Definition hplt: hashP list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. Definition recover_hcodes (t:term): ??(hashinfo term) := match t with @@ -746,8 +779,8 @@ Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv. Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := DO log <~ count_logger ();; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; g_bblock_simu_test no_log_assign (log_new_term (fun _ => RET msg_unknow_term)) @@ -996,8 +1029,8 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; DO result1 <~ g_bblock_simu_test (log_assign dict_info log1) (log_new_term (msg_term cr)) @@ -1017,8 +1050,8 @@ Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := DO log1 <~ count_logger ();; DO log2 <~ count_logger ();; DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hht);; - DO hco_list <~ mk_annot (hCons hlht);; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; DO result2 <~ g_bblock_simu_test (log_assign dict_info log1) (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *) @@ -1074,9 +1107,60 @@ End ImpSimu. Require Import FMapPositive. + +Require Import PArith. +Require Import FMapPositive. + Module ImpPosDict <: ImpDict with Module R:=Pos. -Include PosDict. +Module R:=Pos. + +Definition t:=PositiveMap.t. + +Definition get {A} (d:t A) (x:R.t): option A + := PositiveMap.find x d. + +Definition set {A} (d:t A) (x:R.t) (v:A): t A + := PositiveMap.add x v d. + +Local Hint Unfold PositiveMap.E.eq. + +Lemma set_spec_eq A d x (v: A): + get (set d x v) x = Some v. +Proof. + unfold get, set; apply PositiveMap.add_1; auto. +Qed. + +Lemma set_spec_diff A d x y (v: A): + x <> y -> get (set d x v) y = get d y. +Proof. + unfold get, set; intros; apply PositiveMap.gso; auto. +Qed. + +Definition rem {A} (d:t A) (x:R.t): t A + := PositiveMap.remove x d. + +Lemma rem_spec_eq A (d: t A) x: + get (rem d x) x = None. +Proof. + unfold get, rem; apply PositiveMap.grs; auto. +Qed. + +Lemma rem_spec_diff A (d: t A) x y: + x <> y -> get (rem d x) y = get d y. +Proof. + unfold get, rem; intros; apply PositiveMap.gro; auto. +Qed. + + +Definition empty {A}: t A := PositiveMap.empty A. + +Lemma empty_spec A x: + get (empty (A:=A)) x = None. +Proof. + unfold get, empty; apply PositiveMap.gempty; auto. +Qed. + Import PositiveMap. Fixpoint eq_test {A} (d1 d2: t A): ?? bool := diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index 637e8296..d8002375 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -110,17 +110,17 @@ Module HConsing. Export HConsingDefs. (* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) -Axiom xhCons: forall {A}, (hashH A) -> ?? hashConsing A. +Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A. Extract Constant xhCons => "ImpHConsOracles.xhCons". Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". -Definition hCons {A} (hh: hashH A): ?? (hashConsing A) := - DO hco <~ xhCons hh ;; +Definition hCons {A} (hp: hashP A): ?? (hashConsing A) := + DO hco <~ xhCons hp ;; RET {| hC := (fun x => DO x' <~ hC hco x ;; - DO b0 <~ hash_eq hh x.(hdata) x' ;; + DO b0 <~ hash_eq hp x.(hdata) x' ;; assert_b b0 hCons_eq_msg;; RET x'); next_hid := hco.(next_hid); @@ -130,10 +130,10 @@ Definition hCons {A} (hh: hashH A): ?? (hashConsing A) := |}. -Lemma hCons_correct A (hh: hashH A): - WHEN hCons hh ~> hco THEN - (forall x y, WHEN hh.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hh x)=(ignore_hid hh y)) -> - forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hh x.(hdata)=ignore_hid hh x'. +Lemma hCons_correct A (hp: hashP A): + WHEN hCons hp ~> hco THEN + (forall x y, WHEN hp.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hp x)=(ignore_hid hp y)) -> + forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hp x.(hdata)=ignore_hid hp x'. Proof. wlp_simplify. Qed. @@ -149,7 +149,7 @@ Record hashV {A:Type}:= { }. Arguments hashV: clear implicits. -Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashH (hashV A) := {| +Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashP (hashV A) := {| hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data); get_hid := hid; set_hid := fun v id => {| data := v.(data); hid := id |} diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v index 477be65c..de4c7973 100644 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v @@ -130,17 +130,17 @@ Record hashinfo {A: Type} := { Arguments hashinfo: clear implicits. (* for inductive types with intrinsic hash-consing *) -Record hashH {A:Type}:= { +Record hashP {A:Type}:= { hash_eq: A -> A -> ?? bool; get_hid: A -> hashcode; set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *) }. -Arguments hashH: clear implicits. +Arguments hashP: clear implicits. Axiom unknown_hid: hashcode. Extract Constant unknown_hid => "-1". -Definition ignore_hid {A} (hh: hashH A) (hv:A) := set_hid hh hv unknown_hid. +Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid. Record hashExport {A:Type}:= { get_info: hashcode -> ?? hashinfo A; diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml index 3994cae6..2b66899b 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -17,13 +17,13 @@ let make_dict (type key) (p: key Dict.hash_params) = exception Stop;; -let xhCons (type a) (hh:a hashH) = +let xhCons (type a) (hp:a hashP) = (* We use a hash-table, but a hash-set would be sufficient ! *) (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *) (* Ideally, a parameter would allow to select between the weak or full version *) let module MyHashedType = struct type t = a hashinfo - let equal x y = hh.hash_eq x.hdata y.hdata + let equal x y = hp.hash_eq x.hdata y.hdata let hash x = Hashtbl.hash x.hcodes end in let module MyHashtbl = Hashtbl.Make(MyHashedType) in @@ -42,7 +42,7 @@ let xhCons (type a) (hh:a hashH) = match MyHashtbl.find_opt t k with | Some d -> d | None -> (*print_string "+";*) - let d = hh.set_hid k.hdata (MyHashtbl.length t) in + let d = hp.set_hid k.hdata (MyHashtbl.length t) in MyHashtbl.add t {k with hdata = d } d; d); next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); next_hid = (fun () -> MyHashtbl.length t); @@ -58,7 +58,7 @@ let xhCons (type a) (hh:a hashH) = | (j, info)::l' when i>=j -> logs:=l'; info::(step_log i) | _ -> [] in let a = Array.make (MyHashtbl.length t) k in - MyHashtbl.iter (fun k d -> a.(hh.get_hid d) <- k) t; + MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t; { get_info = (fun i -> a.(i)); iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a) diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli index 9f5eca89..5075d176 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -2,4 +2,4 @@ open ImpPrelude open HConsingDefs val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t -val xhCons: 'a hashH -> 'a hashConsing +val xhCons: 'a hashP -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 8b6a372a..649dd083 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -3,104 +3,90 @@ *) +Require Coq.Logic.FunctionalExtensionality. (* not really necessary -- see lemma at the end *) Require Setoid. (* in order to rewrite <-> *) Require Export AbstractBasicBlocksDef. Require Import List. Require Import ImpPrelude. Import HConsingDefs. -Module Type PseudoRegDictionary. -Declare Module R: PseudoRegisters. - -Parameter t: Type -> Type. - -Parameter get: forall {A}, t A -> R.t -> option A. - -Parameter set: forall {A}, t A -> R.t -> A -> t A. - -Parameter set_spec_eq: forall A d x (v: A), - get (set d x v) x = Some v. - -Parameter set_spec_diff: forall A d x y (v: A), - x <> y -> get (set d x v) y = get d y. - -Parameter empty: forall {A}, t A. - -Parameter empty_spec: forall A x, - get (empty (A:=A)) x = None. - -End PseudoRegDictionary. - - -Module SimuTheory (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R). +Module SimuTheory (L: SeqLanguage). Export L. Export LP. -Export Terms. + +Inductive term := + | Input (x:R.t) + | App (o: op) (l: list_term) +with list_term := + | LTnil + | LTcons (t:term) (l:list_term) + . + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x => Some (m x) + | App o l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | LTnil => Some nil + | LTcons t l' => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. (* the symbolic memory: - pre: pre-condition expressing that the computation has not yet abort on a None. - post: the post-condition for each pseudo-register *) -Record smem:= {pre: genv -> mem -> Prop; post: Dict.t term}. - -Coercion post: smem >-> Dict.t. +Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}. (** initial symbolic memory *) -Definition smem_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}. +Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}. -Definition smem_get (d:Dict.t term) x := - match Dict.get d x with - | None => Input x unknown_hid - | Some t => t - end. - -Fixpoint exp_term (e: exp) (d old: Dict.t term): term := +Fixpoint exp_term (e: exp) (d old: smem) : term := match e with - | PReg x => smem_get d x - | Op o le => App o (list_exp_term le d old) unknown_hid + | PReg x => d x + | Op o le => App o (list_exp_term le d old) | Old e => exp_term e old old end -with list_exp_term (le: list_exp) (d old: Dict.t term) : list_term := +with list_exp_term (le: list_exp) (d old: smem) : list_term := match le with - | Enil => LTnil unknown_hid - | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) unknown_hid + | Enil => LTnil + | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) | LOld le => list_exp_term le old old end. -(** evaluation of the post-condition *) -Definition smem_eval ge (d: Dict.t term) x (m:mem) := - term_eval ge (smem_get d x) m. (** assignment of the symbolic memory *) Definition smem_set (d:smem) x (t:term) := - {| pre:=(fun ge m => (smem_eval ge d x m) <> None /\ (d.(pre) ge m)); - post:=Dict.set d x t |}. + {| pre:=(fun ge m => (term_eval ge (d x) m) <> None /\ (d.(pre) ge m)); + post:=fun y => if R.eq_dec x y then t else d y |}. Section SIMU_THEORY. Variable ge: genv. Lemma set_spec_eq d x t m: - smem_eval ge (smem_set d x t) x m = term_eval ge t m. + term_eval ge (smem_set d x t x) m = term_eval ge t m. Proof. - unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_eq; simpl; auto. + unfold smem_set; simpl; case (R.eq_dec x x); try congruence. Qed. Lemma set_spec_diff d x y t m: - x <> y -> smem_eval ge (smem_set d x t) y m = smem_eval ge d y m. + x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m. Proof. - intros; unfold smem_eval, smem_set, smem_get; simpl; rewrite Dict.set_spec_diff; simpl; auto. + unfold smem_set; simpl; case (R.eq_dec x y); try congruence. Qed. -Lemma smem_eval_empty x m: smem_eval ge smem_empty x m = Some (m x). -Proof. - unfold smem_eval, smem_get; rewrite Dict.empty_spec; simpl; auto. -Qed. - -Hint Rewrite set_spec_eq smem_eval_empty: dict_rw. - Fixpoint inst_smem (i: inst) (d old: smem): smem := match i with | nil => d @@ -116,8 +102,9 @@ Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := let d':=inst_smem i d d in bblock_smem_rec p' d' end. - +(* Local Hint Resolve smem_eval_empty. +*) Definition bblock_smem: bblock -> smem := fun p => bblock_smem_rec p smem_empty. @@ -140,37 +127,36 @@ Qed. Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic. Lemma term_eval_exp e (od:smem) m0 old: - (forall x, smem_eval ge od x m0 = Some (old x)) -> - forall d m1, - (forall x, smem_eval ge (d:smem) x m0 = Some (m1 x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (d:smem) m1, + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. Proof. - unfold smem_eval in * |- *; intro H. + intro H. induction e using exp_mut with - (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (smem_get d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); + (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); simpl; auto. - intros; erewrite IHe; eauto. - intros. erewrite IHe, IHe0; eauto. Qed. -Lemma inst_smem_abort i m0 x old: forall d, +Lemma inst_smem_abort i m0 x old: forall (d:smem), pre (inst_smem i d old) ge m0 -> - smem_eval ge d x m0 = None -> - smem_eval ge (inst_smem i d old) x m0 = None. + term_eval ge (d x) m0 = None -> + term_eval ge (inst_smem i d old x) m0 = None. Proof. induction i as [|[y e] i IHi]; simpl; auto. intros d VALID H; erewrite IHi; eauto. clear IHi. - destruct (R.eq_dec x y). - * subst; autorewrite with dict_rw. - generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. - unfold smem_set; simpl; intuition congruence. - * rewrite set_spec_diff; auto. + unfold smem_set; simpl; destruct (R.eq_dec y x); auto. + subst; + generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold smem_set; simpl. intuition congruence. Qed. Lemma block_smem_rec_abort p m0 x: forall d, pre (bblock_smem_rec p d) ge m0 -> - smem_eval ge d x m0 = None -> - smem_eval ge (bblock_smem_rec p d) x m0 = None. + term_eval ge (d x) m0 = None -> + term_eval ge (bblock_smem_rec p d x) m0 = None. Proof. induction p; simpl; auto. intros d VALID H; erewrite IHp; eauto. clear IHp. @@ -178,11 +164,11 @@ Proof. Qed. Lemma inst_smem_Some_correct1 i m0 old (od:smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> forall (m1 m2: mem) (d: smem), inst_run ge i m1 old = Some m2 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x). + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x). Proof. intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. - inversion_clear H; eauto. @@ -190,16 +176,14 @@ Proof. destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. refine (IHi _ _ _ _ _ _); eauto. clear x0; intros x0. - unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. Qed. Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), run ge p m1 = Some m2 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x). + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). Proof. Local Hint Resolve inst_smem_Some_correct1. induction p as [ | i p]; simpl; intros m1 m2 d H. @@ -212,39 +196,37 @@ Qed. Lemma bblock_smem_Some_correct1 p m0 m1: run ge p m0 = Some m1 - -> forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x). + -> forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x). Proof. intros; eapply bblocks_smem_rec_Some_correct1; eauto. Qed. Lemma inst_smem_None_correct i m0 old (od: smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> forall m1 d, pre (inst_smem i d od) ge m0 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - inst_run ge i m1 old = None -> exists x, smem_eval ge (inst_smem i d od) x m0 = None. + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + inst_run ge i m1 old = None -> exists x, term_eval ge (inst_smem i d od x) m0 = None. Proof. intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - discriminate. - intros VALID H0. destruct (exp_eval ge e m1 old) eqn: Heqov. + refine (IHi _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + intros x0; unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + intuition. constructor 1 with (x:=x); simpl. apply inst_smem_abort; auto. - autorewrite with dict_rw. + rewrite set_spec_eq. erewrite term_eval_exp; eauto. Qed. Lemma inst_smem_Some_correct2 i m0 old (od: smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> forall (m1 m2: mem) d, pre (inst_smem i d od) ge m0 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - (forall x, smem_eval ge (inst_smem i d od) x m0 = Some (m2 x)) -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x)) -> res_eq (Some m2) (inst_run ge i m1 old). Proof. intro X. @@ -255,20 +237,18 @@ Proof. - intros H. destruct (exp_eval ge e m1 old) eqn: Heqov. + refine (IHi _ _ _ _ _ _); eauto. - intros x0; unfold assign; destruct (R.eq_dec x x0). - * subst. autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + intros x0; unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + generalize (H x). rewrite inst_smem_abort; discriminate || auto. - autorewrite with dict_rw. + rewrite set_spec_eq. erewrite term_eval_exp; eauto. Qed. Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d, pre (bblock_smem_rec p d) ge m0 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> - (forall x, smem_eval ge (bblock_smem_rec p d) x m0 = Some (m2 x)) -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x)) -> res_eq (Some m2) (run ge p m1). Proof. induction p as [|i p]; simpl; intros m1 m2 d VALID H0. @@ -278,7 +258,7 @@ Proof. - intros H. destruct (inst_run ge i m1 m1) eqn: Heqom. + refine (IHp _ _ _ _ _ _); eauto. - + assert (X: exists x, term_eval ge (smem_get (inst_smem i d d) x) m0 = None). + + assert (X: exists x, term_eval ge (inst_smem i d d x) m0 = None). { eapply inst_smem_None_correct; eauto. } destruct X as [x H1]. generalize (H x). @@ -286,21 +266,20 @@ Proof. congruence. Qed. - Lemma bblock_smem_Some_correct2 p m0 m1: pre (bblock_smem p) ge m0 -> - (forall x, smem_eval ge (bblock_smem p) x m0 = Some (m1 x)) + (forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x)) -> res_eq (Some m1) (run ge p m0). Proof. intros; eapply bblocks_smem_rec_Some_correct2; eauto. Qed. Lemma inst_valid i m0 old (od:smem): - (forall x, smem_eval ge od x m0 = Some (old x)) -> + (forall x, term_eval ge (od x) m0 = Some (old x)) -> forall (m1 m2: mem) (d: smem), pre d ge m0 -> inst_run ge i m1 old = Some m2 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> pre (inst_smem i d od) ge m0. Proof. induction i as [|[x e] i IHi]; simpl; auto. @@ -309,17 +288,15 @@ Proof. eapply IHi; eauto. + unfold smem_set in * |- *; simpl. rewrite Hm1; intuition congruence. - + intros x0. unfold assign; destruct (R.eq_dec x x0). - * subst; autorewrite with dict_rw. - erewrite term_eval_exp; eauto. - * rewrite set_spec_diff; auto. + + intros x0. unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. Qed. Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), pre d ge m0 -> run ge p m1 = Some m2 -> - (forall x, smem_eval ge d x m0 = Some (m1 x)) -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> pre (bblock_smem_rec p d) ge m0. Proof. Local Hint Resolve inst_valid. @@ -337,22 +314,26 @@ Proof. unfold smem_empty; simpl. auto. Qed. -Definition smem_valid ge d m := pre d ge m /\ forall x, smem_eval ge d x m <> None. +Definition smem_valid ge d m := pre d ge m /\ forall x, term_eval ge (d x) m <> None. + +Definition smem_simu (d1 d2: smem): Prop := + (forall m, smem_valid ge d1 m -> smem_valid ge d2 m) + /\ (forall m0 x, smem_valid ge d1 m0 -> + term_eval ge (d1 x) m0 = term_eval ge (d2 x) m0). + Theorem bblock_smem_simu p1 p2: - (forall m, smem_valid ge (bblock_smem p1) m -> smem_valid ge (bblock_smem p2) m) -> - (forall m0 x m1, smem_valid ge (bblock_smem p1) m0 -> smem_eval ge (bblock_smem p1) x m0 = Some m1 -> - smem_eval ge (bblock_smem p2) x m0 = Some m1) -> + smem_simu (bblock_smem p1) (bblock_smem p2) -> bblock_simu ge p1 p2. Proof. Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. - unfold smem_valid; intros INCL EQUIV m DONTFAIL. + intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. - assert (X: forall x, smem_eval ge (bblock_smem p1) x m = Some (m1 x)); eauto. + assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. eapply bblock_smem_Some_correct2; eauto. + destruct (INCL m); intuition eauto. congruence. - + intro x; apply EQUIV; intuition eauto. + + intro x; erewrite <- EQUIV; intuition eauto. congruence. Qed. @@ -370,7 +351,7 @@ Lemma smem_valid_set_decompose_2 d t x m: smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None. Proof. unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. - generalize (VALID x); autorewrite with dict_rw. + generalize (VALID x); rewrite set_spec_eq. tauto. Qed. @@ -379,50 +360,28 @@ Lemma smem_valid_set_proof d x t m: Proof. unfold smem_valid; intros (PRE & VALID) PREt. split. + split; auto. - + intros x0; case (R.eq_dec x x0). - - intros; subst; autorewrite with dict_rw. auto. - - intros. rewrite set_spec_diff; auto. + + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto. Qed. -End SIMU_THEORY. - -End SimuTheory. - -Require Import PArith. -Require Import FMapPositive. - -Module PosDict <: PseudoRegDictionary with Module R:=Pos. - -Module R:=Pos. - -Definition t:=PositiveMap.t. -Definition get {A} (d:t A) (x:R.t): option A - := PositiveMap.find x d. - -Definition set {A} (d:t A) (x:R.t) (v:A): t A - := PositiveMap.add x v d. - -Local Hint Unfold PositiveMap.E.eq. - -Lemma set_spec_eq A d x (v: A): - get (set d x v) x = Some v. -Proof. - unfold get, set; apply PositiveMap.add_1; auto. -Qed. - -Lemma set_spec_diff A d x y (v: A): - x <> y -> get (set d x v) y = get d y. -Proof. - unfold get, set; intros; apply PositiveMap.gso; auto. -Qed. +End SIMU_THEORY. -Definition empty {A}: t A := PositiveMap.empty A. +(** REMARKS: more abstract formulation of the proof... + but relying on functional_extensionality. +*) +Definition smem_correct ge (d: smem) (m: mem) (om: option mem): Prop:= + forall m', om=Some m' <-> (d.(pre) ge m /\ forall x, term_eval ge (d x) m = Some (m' x)). -Lemma empty_spec A x: - get (empty (A:=A)) x = None. +Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m). Proof. - unfold get, empty; apply PositiveMap.gempty; auto. + unfold smem_correct; simpl; intros m'; split. + + intros; split. + * eapply bblock_smem_valid; eauto. + * eapply bblock_smem_Some_correct1; eauto. + + intros (H1 & H2). + destruct (bblock_smem_Some_correct2 ge p m m') as (m2 & X & Y); eauto. + rewrite X. f_equal. + apply FunctionalExtensionality.functional_extensionality; auto. Qed. -End PosDict. \ No newline at end of file +End SimuTheory. -- cgit From 69f4580c239548082d899b3719b5de2d686252c3 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 12 Jun 2019 17:05:55 +0200 Subject: Removing the Admitted warning when running "make check-admitted" --- mppa_k1c/ExtValues.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 8e6aa028..3370fae3 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -424,7 +424,7 @@ Qed. (* Lemma signed_0_eqb : forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero. -Admitted. +Qed. *) Lemma Z_quot_le: forall a b, -- cgit From 60f5b79492144740338e5d77653c4dc3e61606e7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 14 Jun 2019 17:46:11 +0200 Subject: [BROKEN] Replaced the accesses lists by Maps, does not compile --- mppa_k1c/PostpassSchedulingOracle.ml | 66 +++++++++++++++++++++++++++++++----- 1 file changed, 58 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 2fc561ee..c153576b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -699,20 +699,56 @@ let instruction_usages bb = * Latency constraints building *) -type access = { inst: int; loc: location } +(* type access = { inst: int; loc: location } *) -let rec get_accesses llocs laccs = - let accesses loc laccs = List.filter (fun acc -> acc.loc = loc) laccs - in match llocs with - | [] -> [] - | loc :: llocs -> (accesses loc laccs) @ (get_accesses llocs laccs) +let preg2int pr = Camlcoq.P.to_int @@ Asmblockdeps.ppos pr + +let loc2int = function + | Mem -> 1 + | Reg pr -> preg2int pr + +module OrderedLoc : Map.OrderedType = struct + type t = location + let compare l l' = compare (loc2int l) (loc2int l') +end + +module LocMap = Map.Make(OrderedLoc) let rec intlist n = if n < 0 then failwith "intlist: n < 0" else if n = 0 then [] else (n-1) :: (intlist (n-1)) -let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) +let rec list2locmap v = function + | [] -> LocMap.empty + | loc :: l -> LocMap.add loc v (list2locmap v l) + +let get_accesses locs locmap = List.map (fun l _ -> List.mem l locs) locmap + +let latency_constraints bb = + let written = ref LocMap.empty + and read = ref LocMap.empty + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: inst_info) = + let write_accesses = list2locmap !count i.write_locs + and read_accesses = list2locmap !count i.read_locs + in let raw = get_accesses i.read_locs !written + and waw = get_accesses i.write_locs !written + and war = get_accesses i.write_locs !read + in begin + Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; + if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); + written := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; + read := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) + +(* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] and read = ref [] and count = ref 0 @@ -734,6 +770,7 @@ let latency_constraints bb = (* failwith "latency_constraints: not implemented" count := !count + 1 end in (List.iter step instr_infos; !constraints) +*) (** * Using the InstructionScheduler @@ -829,7 +866,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -let do_schedule bb = +let real_do_schedule bb = let problem = build_problem bb in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then validated_scheduler cascaded_scheduler @@ -850,6 +887,19 @@ let do_schedule bb = end; bundles) +let do_schedule bb = + let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb + in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime) + in let sched = real_do_schedule bb + in let refer = ref sched + in begin + for i = 1 to 100-1 do + refer := (if i > 0 then real_do_schedule bb else real_do_schedule bb); + done; + Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time); + sched + end + (** * Dumb schedule if the above doesn't work *) -- cgit From 8697837760ad3b0002ed94ff3e83a60a15c259a1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 14:31:37 +0200 Subject: [NOT TESTED] ça compile MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassSchedulingOracle.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index c153576b..9912fbcb 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,7 +707,7 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module OrderedLoc : Map.OrderedType = struct +module OrderedLoc = struct type t = location let compare l l' = compare (loc2int l) (loc2int l') end @@ -723,7 +723,7 @@ let rec list2locmap v = function | [] -> LocMap.empty | loc :: l -> LocMap.add loc v (list2locmap v l) -let get_accesses locs locmap = List.map (fun l _ -> List.mem l locs) locmap +let get_accesses locs locmap = LocMap.filter (fun l _ -> List.mem l locs) locmap let latency_constraints bb = let written = ref LocMap.empty @@ -738,12 +738,12 @@ let latency_constraints bb = and waw = get_accesses i.write_locs !written and war = get_accesses i.write_locs !read in begin - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; - Map.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; + LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); - written := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; - read := Map.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; + written := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; + read := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; count := !count + 1 end in (List.iter step instr_infos; !constraints) -- cgit From 45e8a0997169b0b081f3cea500debc237e4a8c76 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 18:43:14 +0200 Subject: [BROKEN] Fixed the dependency oracle, does not compile I was removing too many dependencies --- mppa_k1c/PostpassSchedulingOracle.ml | 50 ++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 9912fbcb..75dc2495 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,26 +707,59 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module OrderedLoc = struct - type t = location - let compare l l' = compare (loc2int l) (loc2int l') +module HashedLoc = struct + type t = { loc: location; key: int } + let equal l1 l2 = (l1.key = l2.key) + let hash l = l.key + let create (l:location) : t = { loc=l; key = loc2int l } end -module LocMap = Map.Make(OrderedLoc) +module LocHash = Hashtbl.Make(HashedLoc) + +(* Hash table : location => list of instruction ids *) let rec intlist n = if n < 0 then failwith "intlist: n < 0" else if n = 0 then [] else (n-1) :: (intlist (n-1)) +(* Returns a list of instruction ids *) +let rec get_accesses hashloc = function + | [] -> [] + | loc :: llocs -> (LocHash.find hashloc loc) @ (get_accesses hashloc llocs) + +let latency_constraints bb = + let written = LocHash.create 0 + and read = LocHash.create 0 + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: inst_info) = + let raw = get_accesses i.read_locs written + and waw = get_accesses i.write_locs written + and war = get_accesses i.write_locs read + in begin + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; + if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); + (* Updating "read" and "written" hashmaps *) + List.iter (fun loc -> + begin + LocHash.replace written loc [!count]; + LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) + end) i.write_locs; + List.iter (fun loc -> LocHash.replace read loc (LocHash.find read loc)) i.read_locs; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) + +(* let rec list2locmap v = function | [] -> LocMap.empty | loc :: l -> LocMap.add loc v (list2locmap v l) -let get_accesses locs locmap = LocMap.filter (fun l _ -> List.mem l locs) locmap - -let latency_constraints bb = - let written = ref LocMap.empty + let written = ref (LocHash.create 0) and read = ref LocMap.empty and count = ref 0 and constraints = ref [] @@ -747,6 +780,7 @@ let latency_constraints bb = count := !count + 1 end in (List.iter step instr_infos; !constraints) + *) (* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) let written = ref [] -- cgit From 99cf129352db347291e893d1102df9804fd04472 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 17 Jun 2019 18:53:12 +0200 Subject: [BROKEN] still broken, just fixing a logical detail --- mppa_k1c/PostpassSchedulingOracle.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 75dc2495..09d5e15b 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -749,7 +749,7 @@ let latency_constraints bb = LocHash.replace written loc [!count]; LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) end) i.write_locs; - List.iter (fun loc -> LocHash.replace read loc (LocHash.find read loc)) i.read_locs; + List.iter (fun loc -> LocHash.replace read loc ((!count) :: (LocHash.find read loc))) i.read_locs; count := !count + 1 end in (List.iter step instr_infos; !constraints) -- cgit From b480d21954b63abb93411e7691e4cafc9d658f3f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 18 Jun 2019 16:02:40 +0200 Subject: [NOT TESTED] Compiles and should work ? --- mppa_k1c/PostpassSchedulingOracle.ml | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 09d5e15b..b54dfeda 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -707,14 +707,15 @@ let loc2int = function | Mem -> 1 | Reg pr -> preg2int pr -module HashedLoc = struct +(* module HashedLoc = struct type t = { loc: location; key: int } let equal l1 l2 = (l1.key = l2.key) let hash l = l.key let create (l:location) : t = { loc=l; key = loc2int l } -end +end *) -module LocHash = Hashtbl.Make(HashedLoc) +(* module LocHash = Hashtbl.Make(HashedLoc) *) +module LocHash = Hashtbl (* Hash table : location => list of instruction ids *) @@ -723,21 +724,26 @@ let rec intlist n = else if n = 0 then [] else (n-1) :: (intlist (n-1)) +let find_in_hash hashloc loc = + match LocHash.find_opt hashloc loc with + | Some idl -> idl + | None -> [] + (* Returns a list of instruction ids *) -let rec get_accesses hashloc = function +let rec get_accesses hashloc (ll: location list) = match ll with | [] -> [] - | loc :: llocs -> (LocHash.find hashloc loc) @ (get_accesses hashloc llocs) + | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) let latency_constraints bb = - let written = LocHash.create 0 - and read = LocHash.create 0 + let written = LocHash.create 70 + and read = LocHash.create 70 and count = ref 0 and constraints = ref [] and instr_infos = instruction_infos bb in let step (i: inst_info) = - let raw = get_accesses i.read_locs written - and waw = get_accesses i.write_locs written - and war = get_accesses i.write_locs read + let raw = get_accesses written i.read_locs + and waw = get_accesses written i.write_locs + and war = get_accesses read i.write_locs in begin List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; @@ -749,7 +755,7 @@ let latency_constraints bb = LocHash.replace written loc [!count]; LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) end) i.write_locs; - List.iter (fun loc -> LocHash.replace read loc ((!count) :: (LocHash.find read loc))) i.read_locs; + List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs; count := !count + 1 end in (List.iter step instr_infos; !constraints) -- cgit From 82db72dbd06eced8f72ca4a41e08892b908b5036 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 18 Jun 2019 16:08:25 +0200 Subject: Reverting the unwanted time measurement from the other branch --- mppa_k1c/PostpassSchedulingOracle.ml | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b54dfeda..462e9cd0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -906,7 +906,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions -let real_do_schedule bb = +let do_schedule bb = let problem = build_problem bb in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then validated_scheduler cascaded_scheduler @@ -927,19 +927,6 @@ let real_do_schedule bb = end; bundles) -let do_schedule bb = - let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb - in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime) - in let sched = real_do_schedule bb - in let refer = ref sched - in begin - for i = 1 to 100-1 do - refer := (if i > 0 then real_do_schedule bb else real_do_schedule bb); - done; - Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time); - sched - end - (** * Dumb schedule if the above doesn't work *) -- cgit From 0ad6bc290c564ccaffd7df0e7232e133b94895f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 19 Jun 2019 14:39:18 +0200 Subject: pretty print statistics --- mppa_k1c/InstructionScheduler.ml | 69 +++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 1fa55c9b..2836c160 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,7 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(** FIXME - warning fix *) +(* FIXME DUMMY CODE to placate warnings + *) let _ = priority_list_scheduler INSTRUCTION_ORDER;; type bundle = int list;; @@ -367,7 +368,7 @@ let bundles_to_schedule problem bundles : solution = let greedy_scheduler (problem : problem) : solution option = let bundles = make_bundles problem 0 in Some (bundles_to_schedule problem bundles);; - + (* alternate implementation let swap_array_elements a i j = let x = a.(i) in @@ -426,6 +427,7 @@ let max_scheduled_time solution = done; !time;; +(* DM: I think this is buggy *) let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with @@ -1107,17 +1109,6 @@ let ilp_print_problem channel problem pb_type = mapper_final_predecessors = predecessors.(nr_instructions) };; -(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) - -let positive_float_round x = truncate (x +. 0.5) - -let float_round (x : float) : int = - if x > 0.0 - then positive_float_round x - else - (positive_float_round (-. x)) - -let rounded_int_of_string x = float_round (float_of_string x) - let ilp_read_solution mapper channel = let times = Array.make (match mapper.mapper_pb_type with @@ -1143,7 +1134,7 @@ let ilp_read_solution mapper channel = (if tnumber < 0 || tnumber >= (Array.length times) then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); let value = - try rounded_int_of_string (String.sub line (space+1) ((String.length line)-space-1)) + try int_of_string (String.sub line (space+1) ((String.length line)-space-1)) with Failure _ -> failwith "bad ilp output: not a time number" in @@ -1162,22 +1153,15 @@ let ilp_read_solution mapper channel = times;; let ilp_solver = ref "ilp_solver" - -let problem_nr = ref 0 - -let do_with_resource destroy x f = - try - let r = f x in - destroy x; r - with exn -> destroy x; raise exn;; - + let ilp_scheduler pb_type problem = try - let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr - and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in - incr problem_nr; - let mapper = do_with_resource close_out (open_out filename_in) - (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in + let filename_in = "problem.lp" + and filename_out = "problem.sol" in + let opb_problem = open_out filename_in in + let mapper = ilp_print_problem opb_problem problem pb_type in + close_out opb_problem; + begin match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with | Unix.WEXITED 0 -> @@ -1190,20 +1174,33 @@ let ilp_scheduler pb_type problem = end with | Unschedulable -> None;; - + +let current_utime_all () = + let t = Unix.times() in + t.Unix.tms_cutime +. t.Unix.tms_utime;; + +let utime_all_fn fn arg = + let utime_start = current_utime_all () in + let output = fn arg in + let utime_end = current_utime_all () in + (output, utime_end -. utime_start);; + let cascaded_scheduler (problem : problem) = - match validated_scheduler list_scheduler problem with + let (some_initial_solution, list_scheduler_time) = + utime_all_fn (validated_scheduler list_scheduler) problem in + match some_initial_solution with | None -> None | Some initial_solution -> - let solution = reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution problem in + let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in begin let latency2 = get_max_latency solution and latency1 = get_max_latency initial_solution in - if latency2 < latency1 - then Printf.printf "REOPTIMIZING SUCCEEDED %d < %d for %d instructions\n" latency2 latency1 (Array.length problem.instruction_usages) - else if latency2 = latency1 - then Printf.printf "%d unchanged\n" latency1 - else failwith "optimizing not optimizing" + Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" + (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") + (get_nr_instructions problem) + latency1 latency2 + list_scheduler_time reoptimizing_time; + flush stdout end; Some solution;; -- cgit From 80295d3c7cc82c34903f7ed92a77a64870f1920f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 21 Jun 2019 22:07:28 +0200 Subject: -frevlist --- mppa_k1c/InstructionScheduler.ml | 41 +++++++++++++++++++++++++++++------- mppa_k1c/PostpassSchedulingOracle.ml | 2 ++ 2 files changed, 35 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 2836c160..b9e362c7 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -427,7 +427,15 @@ let max_scheduled_time solution = done; !time;; -(* DM: I think this is buggy *) +let recompute_makespan problem solution = + let n = (Array.length solution) - 1 and ms = ref 0 in + List.iter (fun cstr -> + if cstr.instr_to = n + then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) + ) problem.latency_constraints; + !ms;; + +(* Does not take into account latencies to exit point *) let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with @@ -435,11 +443,13 @@ let schedule_reversed (scheduler : problem -> solution option) | Some solution -> let nr_instructions = get_nr_instructions problem and maxi = max_scheduled_time solution in - Some (Array.init (Array.length solution) + let ret = Array.init (Array.length solution) (fun i -> if i < nr_instructions then maxi-solution.(nr_instructions-1-i) - else solution.(i)));; + else solution.(i)) in + ret.(nr_instructions) <- recompute_makespan problem ret; + Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) let reverse_list_scheduler = schedule_reversed list_scheduler;; @@ -1109,6 +1119,17 @@ let ilp_print_problem channel problem pb_type = mapper_final_predecessors = predecessors.(nr_instructions) };; +(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) + +let positive_float_round x = truncate (x +. 0.5) + +let float_round (x : float) : int = + if x > 0.0 + then positive_float_round x + else - (positive_float_round (-. x)) + +let rounded_int_of_string x = float_round (float_of_string x) + let ilp_read_solution mapper channel = let times = Array.make (match mapper.mapper_pb_type with @@ -1134,9 +1155,10 @@ let ilp_read_solution mapper channel = (if tnumber < 0 || tnumber >= (Array.length times) then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); let value = - try int_of_string (String.sub line (space+1) ((String.length line)-space-1)) + let s = String.sub line (space+1) ((String.length line)-space-1) in + try rounded_int_of_string s with Failure _ -> - failwith "bad ilp output: not a time number" + failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) in (if value < 0 then failwith "bad ilp output: negative time"); @@ -1153,11 +1175,14 @@ let ilp_read_solution mapper channel = times;; let ilp_solver = ref "ilp_solver" - + +let problem_nr = ref 0 + let ilp_scheduler pb_type problem = try - let filename_in = "problem.lp" - and filename_out = "problem.sol" in + let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr + and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in + incr problem_nr; let opb_problem = open_out filename_in in let mapper = ilp_print_problem opb_problem problem pb_type in close_out opb_problem; diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 462e9cd0..19eec3e6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -912,6 +912,8 @@ let do_schedule bb = validated_scheduler cascaded_scheduler else if !Clflags.option_fpostpass_sched = "list" then validated_scheduler list_scheduler + else if !Clflags.option_fpostpass_sched = "revlist" then + validated_scheduler reverse_list_scheduler else if !Clflags.option_fpostpass_sched = "greedy" then greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem in match solution with -- cgit From 5be8f955647e5becc5f53b04da2b1c408b6cd277 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 22 Jun 2019 10:09:13 +0200 Subject: schedule from end --- mppa_k1c/InstructionScheduler.ml | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index b9e362c7..c64628ff 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -390,32 +390,36 @@ let array_reverse a = a';; *) +(* unneeded let array_reverse a = let n=Array.length a in Array.init n (fun i -> a.(n-1-i));; + *) let reverse_constraint nr_instructions ctr = - if ctr.instr_to < nr_instructions - then Some - { instr_to = nr_instructions -1 -ctr.instr_from; - instr_from = nr_instructions -1 - ctr.instr_to; - latency = ctr.latency } - else None;; + { instr_to = nr_instructions -ctr.instr_from; + instr_from = nr_instructions - ctr.instr_to; + latency = ctr.latency };; +(* unneeded let rec list_map_filter f = function | [] -> [] | h::t -> (match f h with | None -> list_map_filter f t | Some x -> x :: (list_map_filter f t));; + *) let reverse_problem problem = let nr_instructions = get_nr_instructions problem in { max_latency = problem.max_latency; resource_bounds = problem.resource_bounds; - instruction_usages = array_reverse problem.instruction_usages; - latency_constraints = list_map_filter (reverse_constraint nr_instructions) + instruction_usages = Array.init (nr_instructions + 1) + (fun i -> + if i=0 + then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); + latency_constraints = List.map (reverse_constraint nr_instructions) problem.latency_constraints };; @@ -427,6 +431,7 @@ let max_scheduled_time solution = done; !time;; +(* let recompute_makespan problem solution = let n = (Array.length solution) - 1 and ms = ref 0 in List.iter (fun cstr -> @@ -434,21 +439,17 @@ let recompute_makespan problem solution = then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) ) problem.latency_constraints; !ms;; + *) -(* Does not take into account latencies to exit point *) let schedule_reversed (scheduler : problem -> solution option) (problem : problem) = match scheduler (reverse_problem problem) with | None -> None | Some solution -> - let nr_instructions = get_nr_instructions problem - and maxi = max_scheduled_time solution in - let ret = Array.init (Array.length solution) - (fun i -> - if i < nr_instructions - then maxi-solution.(nr_instructions-1-i) - else solution.(i)) in - ret.(nr_instructions) <- recompute_makespan problem ret; + let nr_instructions = get_nr_instructions problem in + let makespan = max_scheduled_time solution in + let ret = Array.init (nr_instructions + 1) + (fun i -> makespan-solution.(nr_instructions-i)) in Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) -- cgit From 6419d31749d57b4528b2f5f1e54336a141e4e169 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 22 Jun 2019 11:57:06 +0200 Subject: fix makespan computation --- mppa_k1c/InstructionScheduler.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index c64628ff..e182804b 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -449,7 +449,9 @@ let schedule_reversed (scheduler : problem -> solution option) let nr_instructions = get_nr_instructions problem in let makespan = max_scheduled_time solution in let ret = Array.init (nr_instructions + 1) - (fun i -> makespan-solution.(nr_instructions-i)) in + (fun i -> makespan-solution.(nr_instructions-i)) in + ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) + (ret.(nr_instructions)); Some ret;; (** Schedule the problem using a greedy list scheduling algorithm, from the end. *) -- cgit From 44d3868140325950144c16ef7d51423f7f1cbd20 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 23 Jun 2019 19:39:43 +0200 Subject: maj forward_simu_par_wio_bblock_aux en forward_simu_par_wio avec une legere simplification (comme dans le papier) --- mppa_k1c/Asmblockdeps.v | 22 ++++++++++------------ mppa_k1c/Asmvliw.v | 18 +++++++++--------- 2 files changed, 19 insertions(+), 21 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index b11a77ff..a8f81be6 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1081,14 +1081,13 @@ Qed. Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). -Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz: +Theorem forward_simu_par_wio ge fn rsr mr sr bdy ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr rsw mr mw) (prun_iw Ge (trans_block_aux bdy sz ex) sw sr). + match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr). Proof. - intros GENV MSR MSW. unfold parexec_wio_bblock_aux, trans_block_aux. - exploit (forward_simu_par_body bdy ge fn rsr mr sr rsw mw sw); eauto. + intros GENV MSR. unfold parexec_wio, trans_block_aux. + exploit (forward_simu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. destruct (parexec_wio_body _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. @@ -1098,20 +1097,19 @@ Proof. - intros X; erewrite prun_iw_app_None; eauto. Qed. -Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz: +Theorem forward_simu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> match_outcome - match parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw with + match parexec_wio ge fn bdy1 ex (Ptrofs.repr sz) rsr mr with | Next rs' m' => parexec_wio_body ge bdy2 rsr rs' mr m' | Stuck => Stuck end - (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sw sr). + (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). Proof. intros. - exploit (forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy1 ex sz); eauto. - destruct (parexec_wio_bblock_aux _ _ _ _ _ _); simpl. + exploit (forward_simu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. + destruct (parexec_wio _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. eapply forward_simu_par_body; eauto. @@ -1157,7 +1155,7 @@ Proof. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). exploit trans_block_perserves_permutation; eauto. intros Perm. - exploit (forward_simu_par_wio_bblock ge fn rs1 rs1 m1 s1' s1' m1 bdy1 bdy2 (exit b) (size b)); eauto. + exploit (forward_simu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. rewrite <- WIO. clear WIO. intros H; eexists; split. 2: eapply H. unfold prun; eexists; split; eauto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index bb6b7132..c5b7db45 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -148,7 +148,7 @@ Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := | R56R57R58R59 => (GPR56, GPR57, GPR58, GPR59) | R60R61R62R63 => (GPR60, GPR61, GPR62, GPR63) end. - + Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}. Proof. decide equality. Defined. @@ -1553,16 +1553,16 @@ Definition incrPC size_b (rs: regset) := Definition parexec_exit (f: function) ext size_b (rsr rsw: regset) (mw: mem) := parexec_control f ext (incrPC size_b rsr) rsw mw. -Definition parexec_wio_bblock_aux f bdy ext size_b (rsr rsw: regset) (mr mw: mem): outcome := - match parexec_wio_body bdy rsr rsw mr mw with - | Next rsw mw => parexec_exit f ext size_b rsr rsw mw +Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome := + match parexec_wio_body bdy rs rs m m with + | Next rsw mw => parexec_exit f ext size_b rs rsw mw | Stuck => Stuck end. (** non-deterministic (out-of-order writes) parallel execution of bundles *) Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) (o: outcome): Prop := exists bdy1 bdy2, Permutation (bdy1++bdy2) (body bundle) /\ - o=match parexec_wio_bblock_aux f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs rs m m with + o=match parexec_wio f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs m with | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw | Stuck => Stuck end. @@ -1689,7 +1689,7 @@ Inductive step: state -> trace -> state -> Prop := (** parallel in-order writes execution of bundles *) Definition parexec_wio_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome := - parexec_wio_bblock_aux f (body b) (exit b) (Ptrofs.repr (size b)) rs rs m m. + parexec_wio f (body b) (exit b) (Ptrofs.repr (size b)) rs m. Lemma parexec_bblock_write_in_order f b rs m: @@ -1699,7 +1699,7 @@ Proof. constructor 1. - rewrite app_nil_r; auto. - unfold parexec_wio_bblock. - destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto. + destruct (parexec_wio f _ _ _); simpl; auto. Qed. @@ -1777,9 +1777,9 @@ Ltac Det_WIO X := - (* determ *) intros s t1 s1 t2 s2 H H0. inv H; Det_WIO X1; inv H0; Det_WIO X2; Equalities. + split. constructor. auto. - + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + + unfold parexec_wio_bblock, parexec_wio in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. rewrite H8 in X1. discriminate. - + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + + unfold parexec_wio_bblock, parexec_wio in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. rewrite H4 in X2. discriminate. + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. exploit external_call_determ. eexact H6. eexact H13. intros [A B]. -- cgit From 2cad56ee1f3d508d1671628a10da1852c5ee95a7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Jun 2019 11:49:37 +0200 Subject: pretty-printing for extra operations (unfinished) --- mppa_k1c/PrintOp.ml | 39 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 4b833014..8417571a 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -21,7 +21,8 @@ open Printf open Camlcoq open Integers open Op - +open ExtValues + let comparison_name = function | Ceq -> "==" | Cne -> "!=" @@ -58,6 +59,19 @@ let print_condition reg pp = function | _ -> fprintf pp "" +let print_condition0 reg pp cond0 rc = + match cond0 with + | Ccomp0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccompu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + | Ccompl0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccomplu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + +let int_of_s14 = function + | SHIFT1 -> 1 + | SHIFT2 -> 2 + | SHIFT3 -> 3 + | SHIFT4 -> 4 + let print_operation reg pp = function | Omove, [r1] -> reg pp r1 | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) @@ -154,6 +168,29 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfsl(stop, start), [r1] -> fprintf pp "extfsl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oinsf(stop, start), [r1; r2] -> fprintf pp "insf(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Oinsfl(stop, start), [r1; r2] -> fprintf pp "insfl(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Osel(cond0, ty), [r1; r2; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %a" reg r1 reg r2 + | Oselimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %ld" reg r1 (camlint_of_coqint imm) + | Osellimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) + | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 + | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) + | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "" let print_addressing reg pp = function -- cgit From 0372e87d41994a24cf001eba00a5797f80192c29 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Jun 2019 12:15:45 +0200 Subject: op printing (still incomplete) --- mppa_k1c/PrintOp.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 8417571a..575fa94f 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -168,6 +168,7 @@ let print_operation reg pp = function | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 | Ocmp c, args -> print_condition reg pp (c, args) + | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 @@ -184,14 +185,24 @@ let print_operation reg pp = function print_condition0 reg pp cond0 rc; fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "" + | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) + | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) + | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 + | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 + | (Omaddimm imm), [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) + | (Omaddlimm imm), [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) + | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 + | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 + | _, _ -> fprintf pp "" let print_addressing reg pp = function | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) -- cgit From d0d234e3a8b195519f60f224b40cf74c6a7691d7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 9 Jul 2019 17:57:22 +0200 Subject: Replaced the solution -> bundles part by an algorithm hopefully linear --- mppa_k1c/PostpassSchedulingOracle.ml | 93 +++++++++++++++--------------------- 1 file changed, 39 insertions(+), 54 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 19eec3e6..0eff8788 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -760,58 +760,6 @@ let latency_constraints bb = end in (List.iter step instr_infos; !constraints) -(* -let rec list2locmap v = function - | [] -> LocMap.empty - | loc :: l -> LocMap.add loc v (list2locmap v l) - - let written = ref (LocHash.create 0) - and read = ref LocMap.empty - and count = ref 0 - and constraints = ref [] - and instr_infos = instruction_infos bb - in let step (i: inst_info) = - let write_accesses = list2locmap !count i.write_locs - and read_accesses = list2locmap !count i.read_locs - in let raw = get_accesses i.read_locs !written - and waw = get_accesses i.write_locs !written - and war = get_accesses i.write_locs !read - in begin - LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; - LocMap.iter (fun l i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; - if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); - written := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !written write_accesses; - read := LocMap.union (fun _ i1 i2 -> if i1 < i2 then Some i2 else Some i1) !read read_accesses; - count := !count + 1 - end - in (List.iter step instr_infos; !constraints) - *) - -(* let latency_constraints bb = (* failwith "latency_constraints: not implemented" *) - let written = ref [] - and read = ref [] - and count = ref 0 - and constraints = ref [] - and instr_infos = instruction_infos bb - in let step (i: inst_info) = - let write_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.write_locs - and read_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.read_locs - in let raw = get_accesses i.read_locs !written - and waw = get_accesses i.write_locs !written - and war = get_accesses i.write_locs !read - in begin - List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = (List.nth instr_infos acc.inst).latency} :: !constraints) (raw @ waw); - List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war; - (* If it's a control instruction, add an extra 0-lat dependency between this instruction and all the previous ones *) - if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); - written := write_accesses @ !written; - read := read_accesses @ !read; - count := !count + 1 - end - in (List.iter step instr_infos; !constraints) -*) - (** * Using the InstructionScheduler *) @@ -880,15 +828,52 @@ let find_all_indices m l = else find m (off+1) l in find m 0 l +module TimeHash = Hashtbl + +(* Hash table : time => list of instruction ids *) + +let hashtbl2list h maxint = + let rec f i = match TimeHash.find_opt h i with + | None -> if (i > maxint) then [] else (f (i+1)) + | Some bund -> bund :: (f (i+1)) + in f 0 + +let find_max l = + let rec f = function + | [] -> None + | e :: l -> match f l with + | None -> Some e + | Some m -> if (e > m) then Some e else Some m + in match (f l) with + | None -> raise Not_found + | Some m -> m + (* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) -let minpack_list l = +let minpack_list (l: int list) = + let timehash = TimeHash.create (List.length l) + in let rec f i = function + | [] -> () + | t::l -> begin + (match TimeHash.find_opt timehash t with + | None -> TimeHash.add timehash t [i] + | Some bund -> TimeHash.replace timehash t (bund @ [i])); + f (i+1) l + end + in begin + f 0 l; + hashtbl2list timehash (find_max l) + end;; + +(* let minpack_list l = let mins = find_mins l in List.map (fun m -> find_all_indices m l) mins + *) let bb_to_instrs bb = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) let bundlize_solution bb sol = - let packs = minpack_list (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) + let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) + in let packs = minpack_list tmp and instrs = bb_to_instrs bb in let rec bund hd = function | [] -> [] -- cgit From d65ab077e80d924bd6f23b36675c9f86f97a1b98 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 17 Jul 2019 16:23:34 +0200 Subject: (#107) Rename "forward_simu" into "bisimu" --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a8f81be6..9855afa2 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -842,7 +842,7 @@ Qed. -Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: +Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> @@ -994,7 +994,7 @@ Local Ltac preg_eq_discr r rd := Qed. -Theorem forward_simu_par_body: +Theorem bisimu_par_body: forall bdy ge fn rsr mr sr rsw mw sw, Ge = Genv ge fn -> match_states (State rsr mr) sr -> @@ -1003,13 +1003,13 @@ Theorem forward_simu_par_body: Proof. induction bdy as [|i bdy]; simpl; eauto. intros. - exploit (forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. + exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. destruct (parexec_basic_instr _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: +Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> @@ -1067,37 +1067,37 @@ Proof. intros rr; destruct rr; unfold incrPC; Simpl. Qed. -Theorem forward_simu_par_exit ex sz ge fn rsr rsw mr mw sr sw: +Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> match_outcome (parexec_exit ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. intros; unfold parexec_exit. - exploit (forward_simu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. + exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. apply extensionality. intros; destruct x; simpl; auto. Qed. Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). -Theorem forward_simu_par_wio ge fn rsr mr sr bdy ex sz: +Theorem bisimu_par_wio ge fn rsr mr sr bdy ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr). Proof. intros GENV MSR. unfold parexec_wio, trans_block_aux. - exploit (forward_simu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. + exploit (bisimu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. destruct (parexec_wio_body _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. - exploit (forward_simu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. + exploit (bisimu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. subst Ge; simpl. destruct MSR as (Y1 & Y2). erewrite Y2; simpl. destruct (inst_prun _ _ _ _ _); simpl; auto. - intros X; erewrite prun_iw_app_None; eauto. Qed. -Theorem forward_simu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: +Theorem bisimu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_outcome @@ -1108,11 +1108,11 @@ Theorem forward_simu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). Proof. intros. - exploit (forward_simu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. + exploit (bisimu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. destruct (parexec_wio _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite prun_iw_app_Some; eauto. - eapply forward_simu_par_body; eauto. + eapply bisimu_par_body; eauto. - intros; erewrite prun_iw_app_None; eauto. Qed. @@ -1143,7 +1143,7 @@ Proof. apply Permutation_app_comm. Qed. -Theorem forward_simu_par rs1 m1 s1' b ge fn o2: +Theorem bisimu_par rs1 m1 s1' b ge fn o2: Ge = Genv ge fn -> match_states (State rs1 m1) s1' -> parexec_bblock ge fn b rs1 m1 o2 -> @@ -1155,7 +1155,7 @@ Proof. inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). exploit trans_block_perserves_permutation; eauto. intros Perm. - exploit (forward_simu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. + exploit (bisimu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. rewrite <- WIO. clear WIO. intros H; eexists; split. 2: eapply H. unfold prun; eexists; split; eauto. @@ -1163,16 +1163,16 @@ Proof. Qed. (* sequential execution *) -Theorem forward_simu_basic ge fn bi rs m s: +Theorem bisimu_basic ge fn bi rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s). Proof. intros; unfold exec_basic_instr. rewrite inst_run_prun. - eapply forward_simu_par_wio_basic; eauto. + eapply bisimu_par_wio_basic; eauto. Qed. -Lemma forward_simu_body: +Lemma bisimu_body: forall bdy ge fn rs m s, Ge = Genv ge fn -> match_states (State rs m) s -> @@ -1180,33 +1180,33 @@ Lemma forward_simu_body: Proof. induction bdy as [|i bdy]; simpl; eauto. intros. - exploit (forward_simu_basic ge fn i rs m s); eauto. + exploit (bisimu_basic ge fn i rs m s); eauto. destruct (exec_basic_instr _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. -Theorem forward_simu_exit ge fn b rs m s: +Theorem bisimu_exit ge fn b rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_control ge fn (exit b) (nextblock b rs) m) (inst_run Ge (trans_pcincr (size b) (trans_exit (exit b))) s s). Proof. intros; unfold exec_control, nextblock. rewrite inst_run_prun. - apply (forward_simu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. + apply (bisimu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. Qed. -Theorem forward_simu rs m b ge fn s: +Theorem bisimu rs m b ge fn s: Ge = Genv ge fn -> match_states (State rs m) s -> match_outcome (exec_bblock ge fn b rs m) (exec Ge (trans_block b) s). Proof. intros GENV MS. unfold exec_bblock. - exploit (forward_simu_body (body b) ge fn rs m s); eauto. + exploit (bisimu_body (body b) ge fn rs m s); eauto. unfold exec, trans_block; simpl. destruct (exec_body _ _ _ _); simpl. - intros (s' & X1 & X2). erewrite run_app_Some; eauto. - exploit (forward_simu_exit ge fn b rs0 m0 s'); eauto. + exploit (bisimu_exit ge fn b rs0 m0 s'); eauto. subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl. destruct (inst_run _ _ _); simpl; auto. - intros X; erewrite run_app_None; eauto. @@ -1243,10 +1243,10 @@ Lemma bblock_para_check_correct ge fn bb rs m rs' m': det_parexec ge fn bb rs m rs' m'. Proof. intros H H0 H1 o H2. unfold bblock_para_check in H1. - exploit (forward_simu rs m bb ge fn); eauto. eapply trans_state_match. + exploit (bisimu rs m bb ge fn); eauto. eapply trans_state_match. rewrite H0; simpl. intros (s2' & EXEC & MS). - exploit forward_simu_par. 2: apply (trans_state_match (State rs m)). all: eauto. + exploit bisimu_par. 2: apply (trans_state_match (State rs m)). all: eauto. intros (o2' & PRUN & MO). exploit parallelizable_correct. apply is_para_correct_aux. eassumption. intro. eapply H3 in PRUN. clear H3. destruct o2'. @@ -1280,8 +1280,8 @@ Proof. unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. generalize (H2 (trans_state (State rs m))); clear H2. intro H2. - exploit (forward_simu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. - exploit (forward_simu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. + exploit (bisimu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. + exploit (bisimu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. destruct (exec_bblock ge fn p1 rs m); try congruence. intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3. -- cgit From 2ed659b796c97de9d2854e73dfe3e803a92a67da Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:24:20 +0200 Subject: Typo in Prevsubxw --- mppa_k1c/TargetPrinter.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 8365d54f..674695d9 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -540,7 +540,7 @@ module Target (*: TARGET*) = | Psubw (rd, rs1, rs2) -> fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 | Prevsubxw (s14, rd, rs1, rs2) -> - fprintf oc " subx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) ireg rd ireg rs1 ireg rs2 | Pmulw (rd, rs1, rs2) -> fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 -- cgit From d697fd077a83d572975c8305baa1f35edca9a05a Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:25:21 +0200 Subject: (#137) Removed the useless strings in PostpassSchedulingOracle --- mppa_k1c/PostpassSchedulingOracle.ml | 591 +++++++++++++++-------------------- 1 file changed, 254 insertions(+), 337 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 0eff8788..af66bdb6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -15,208 +15,242 @@ type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of of type location = Reg of preg | Mem +type real_instruction = + (* ALU *) + | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sbfxw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw + | Addd | Andd | Compd | Muld | Ord | Sbfd | Sbfxd | Srad | Srld | Slld | Srsd | Xord + | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd + | Maddw | Maddd | Msbfw | Msbfd | Cmoved + | Make | Nop | Extfz | Extfs | Insf + | Addxw | Addxd + (* LSU *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo + | Sb | Sh | Sw | Sd | Sq | So + (* BCU *) + | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set + (* FPU *) + | Fabsd | Fabsw | Fnegw | Fnegd + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz + | Fcompw | Fcompd + type ab_inst_rec = { - inst: string; (* name of the pseudo instruction *) + inst: real_instruction; write_locs : location list; read_locs : location list; imm : immediate option; is_control : bool; } -(** Asmvliw constructor to string functions *) +(** Asmvliw constructor to real instructions *) exception OpaqueInstruction -let arith_rr_str = function - | Pcvtl2w -> "Pcvtl2w" - | Pmv -> "Pmv" - | Pnegw -> "Pnegw" - | Pnegl -> "Pnegl" - | Psxwd -> "Psxwd" - | Pzxwd -> "Pzxwd" - | Pextfz(_,_) -> "Pextfz" - | Pextfs(_,_) -> "Pextfs" - | Pextfzl(_,_) -> "Pextfzl" - | Pextfsl(_,_) -> "Pextfsl" - | Pfabsw -> "Pfabsw" - | Pfabsd -> "Pfabsd" - | Pfnegw -> "Pfnegw" - | Pfnegd -> "Pfnegd" - | Pfnarrowdw -> "Pfnarrowdw" - | Pfwidenlwd -> "Pfwidenlwd" - | Pfloatwrnsz -> "Pfloatwrnsz" - | Pfloatuwrnsz -> "Pfloatuwrnsz" - | Pfloatudrnsz -> "Pfloatudrnsz" - | Pfloatdrnsz -> "Pfloatdrnsz" - | Pfixedwrzz -> "Pfixedwrzz" - | Pfixeduwrzz -> "Pfixeduwrzz" - | Pfixeddrzz -> "Pfixeddrzz" - | Pfixedudrzz -> "Pfixedudrzz" - | Pfixeddrzz_i32 -> "Pfixeddrzz_i32" - | Pfixedudrzz_i32 -> "Pfixedudrzz_i32" - -let arith_rrr_str = function - | Pcompw it -> "Pcompw" - | Pcompl it -> "Pcompl" - | Pfcompw ft -> "Pfcompw" - | Pfcompl ft -> "Pfcompl" - | Paddw -> "Paddw" - | Paddxw _ -> "Paddxw" - | Psubw -> "Psubw" - | Prevsubxw _ -> "Psubxw" - | Pmulw -> "Pmulw" - | Pandw -> "Pandw" - | Pnandw -> "Pnandw" - | Porw -> "Porw" - | Pnorw -> "Pnorw" - | Pxorw -> "Pxorw" - | Pnxorw -> "Pnxorw" - | Pandnw -> "Pandnw" - | Pornw -> "Pornw" - | Psraw -> "Psraw" - | Psrlw -> "Psrlw" - | Psrxw -> "Psrxw" - | Psllw -> "Psllw" - | Paddl -> "Paddl" - | Paddxl _ -> "Paddxl" - | Psubl -> "Psubl" - | Prevsubxl _ -> "Psubxl" - | Pandl -> "Pandl" - | Pnandl -> "Pnandl" - | Porl -> "Porl" - | Pnorl -> "Pnorl" - | Pxorl -> "Pxorl" - | Pnxorl -> "Pnxorl" - | Pandnl -> "Pandnl" - | Pornl -> "Pornl" - | Pmull -> "Pmull" - | Pslll -> "Pslll" - | Psrll -> "Psrll" - | Psrxl -> "Psrxl" - | Psral -> "Psral" - | Pfaddd -> "Pfaddd" - | Pfaddw -> "Pfaddw" - | Pfsbfd -> "Pfsbfd" - | Pfsbfw -> "Pfsbfw" - | Pfmuld -> "Pfmuld" - | Pfmulw -> "Pfmulw" - -let arith_rri32_str = function - | Pcompiw it -> "Pcompiw" - | Paddiw -> "Paddiw" - | Paddxiw _ -> "Paddxiw" - | Prevsubiw -> "Psubiw" - | Prevsubxiw _ -> "Psubxiw" - | Pmuliw -> "Pmuliw" - | Pandiw -> "Pandiw" - | Pnandiw -> "Pnandiw" - | Poriw -> "Poriw" - | Pnoriw -> "Pnoriw" - | Pxoriw -> "Pxoriw" - | Pnxoriw -> "Pnxoriw" - | Pandniw -> "Pandniw" - | Porniw -> "Porniw" - | Psraiw -> "Psraiw" - | Psrxiw -> "Psrxiw" - | Psrliw -> "Psrliw" - | Pslliw -> "Pslliw" - | Proriw -> "Proriw" - | Psllil -> "Psllil" - | Psrlil -> "Psrlil" - | Psrail -> "Psrail" - | Psrxil -> "Psrxil" - -let arith_rri64_str = function - | Pcompil it -> "Pcompil" - | Paddil -> "Paddil" - | Prevsubil -> "Psubil" - | Paddxil _ -> "Paddxil" - | Prevsubxil _ -> "Psubxil" - | Pmulil -> "Pmulil" - | Pandil -> "Pandil" - | Pnandil -> "Pnandil" - | Poril -> "Poril" - | Pnoril -> "Pnoril" - | Pxoril -> "Pxoril" - | Pnxoril -> "Pnxoril" - | Pandnil -> "Pandnil" - | Pornil -> "Pornil" - - -let arith_arr_str = function - | Pinsf (_, _) -> "Pinsf" - | Pinsfl (_, _) -> "Pinsfl" - -let arith_arrr_str = function - | Pmaddw -> "Pmaddw" - | Pmaddl -> "Pmaddl" - | Pmsubw -> "Pmsubw" - | Pmsubl -> "Pmsubl" - | Pcmove _ -> "Pcmove" - | Pcmoveu _ -> "Pcmoveu" - -let arith_arri32_str = function - | Pmaddiw -> "Pmaddiw" - | Pcmoveiw _ -> "Pcmoveiw" - | Pcmoveuiw _ -> "Pcmoveuiw" - -let arith_arri64_str = function - | Pmaddil -> "Pmaddil" - | Pcmoveil _ -> "Pcmoveil" - | Pcmoveuil _ -> "Pcmoveuil" - -let arith_ri32_str = "Pmake" - -let arith_ri64_str = "Pmakel" - -let arith_rf32_str = "Pmakefs" - -let arith_rf64_str = "Pmakef" - -let store_str = function - | Psb -> "Psb" - | Psh -> "Psh" - | Psw -> "Psw" - | Psw_a -> "Psw_a" - | Psd -> "Psd" - | Psd_a -> "Psd_a" - | Pfss -> "Pfss" - | Pfsd -> "Pfsd" - -let load_str = function - | Plb -> "Plb" - | Plbu -> "Plbu" - | Plh -> "Plh" - | Plhu -> "Plhu" - | Plw -> "Plw" - | Plw_a -> "Plw_a" - | Pld -> "Pld" - | Pld_a -> "Pld_a" - | Pfls -> "Pfls" - | Pfld -> "Pfld" - -let set_str = "Pset" -let get_str = "Pget" - -let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false } - -let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false } - -let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false} - -let arith_arri32_rec i rd rs imm32 = { inst = arith_arri32_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } - -let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } - -let arith_arr_rec i rd rs = { inst = arith_arr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false} - -let arith_arrr_rec i rd rs1 rs2 = { inst = arith_arrr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false} - -let arith_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false} +let arith_rr_real = function + | Pcvtl2w -> Addw + | Pmv -> Addd + | Pnegw -> Sbfw + | Pnegl -> Sbfd + | Psxwd -> Extfs + | Pzxwd -> Extfz + | Pextfz(_,_) -> Extfz + | Pextfs(_,_) -> Extfs + | Pextfzl(_,_) -> Extfz + | Pextfsl(_,_) -> Extfs + | Pfabsw -> Fabsw + | Pfabsd -> Fabsd + | Pfnegw -> Fnegw + | Pfnegd -> Fnegd + | Pfnarrowdw -> Fnarrowdw + | Pfwidenlwd -> Fwidenlwd + | Pfloatwrnsz -> Floatwz + | Pfloatuwrnsz -> Floatuwz + | Pfloatudrnsz -> Floatudz + | Pfloatdrnsz -> Floatdz + | Pfixedwrzz -> Fixedwz + | Pfixeduwrzz -> Fixeduwz + | Pfixeddrzz -> Fixeddz + | Pfixedudrzz -> Fixedudz + | Pfixeddrzz_i32 -> Fixeddz + | Pfixedudrzz_i32 -> Fixedudz + +let arith_rrr_real = function + | Pcompw it -> Compw + | Pcompl it -> Compd + | Pfcompw ft -> Fcompw + | Pfcompl ft -> Fcompd + | Paddw -> Addw + | Paddxw _ -> Addxw + | Psubw -> Sbfw + | Prevsubxw _ -> Sbfxw + | Pmulw -> Mulw + | Pandw -> Andw + | Pnandw -> Nandw + | Porw -> Orw + | Pnorw -> Norw + | Pxorw -> Xorw + | Pnxorw -> Nxorw + | Pandnw -> Andnw + | Pornw -> Ornw + | Psraw -> Sraw + | Psrlw -> Srlw + | Psrxw -> Srsw + | Psllw -> Sllw + | Paddl -> Addd + | Paddxl _ -> Addxd + | Psubl -> Sbfd + | Prevsubxl _ -> Sbfxd + | Pandl -> Andd + | Pnandl -> Nandd + | Porl -> Ord + | Pnorl -> Nord + | Pxorl -> Xord + | Pnxorl -> Nxord + | Pandnl -> Andnd + | Pornl -> Ornd + | Pmull -> Muld + | Pslll -> Slld + | Psrll -> Srld + | Psrxl -> Srsd + | Psral -> Srad + | Pfaddd -> Faddd + | Pfaddw -> Faddw + | Pfsbfd -> Fsbfd + | Pfsbfw -> Fsbfw + | Pfmuld -> Fmuld + | Pfmulw -> Fmulw + +let arith_rri32_real = function + | Pcompiw it -> Compw + | Paddiw -> Addw + | Paddxiw _ -> Addxw + | Prevsubiw -> Sbfw + | Prevsubxiw _ -> Sbfxw + | Pmuliw -> Mulw + | Pandiw -> Andw + | Pnandiw -> Nandw + | Poriw -> Orw + | Pnoriw -> Norw + | Pxoriw -> Xorw + | Pnxoriw -> Nxorw + | Pandniw -> Andnw + | Porniw -> Ornw + | Psraiw -> Sraw + | Psrxiw -> Srsw + | Psrliw -> Srlw + | Pslliw -> Sllw + | Proriw -> Rorw + | Psllil -> Slld + | Psrlil -> Srld + | Psrail -> Srad + | Psrxil -> Srsd + +let arith_rri64_real = function + | Pcompil it -> Compd + | Paddil -> Addd + | Prevsubil -> Sbfd + | Paddxil _ -> Addxd + | Prevsubxil _ -> Sbfxd + | Pmulil -> Muld + | Pandil -> Andd + | Pnandil -> Nandd + | Poril -> Ord + | Pnoril -> Nord + | Pxoril -> Xord + | Pnxoril -> Nxord + | Pandnil -> Andnd + | Pornil -> Ornd + + +let arith_arr_real = function + | Pinsf (_, _) -> Insf + | Pinsfl (_, _) -> Insf + +let arith_arrr_real = function + | Pmaddw -> Maddw + | Pmaddl -> Maddd + | Pmsubw -> Msbfw + | Pmsubl -> Msbfd + | Pcmove _ -> Cmoved + | Pcmoveu _ -> Cmoved + +let arith_arri32_real = function + | Pmaddiw -> Maddw + | Pcmoveiw _ -> Cmoved + | Pcmoveuiw _ -> Cmoved + +let arith_arri64_real = function + | Pmaddil -> Maddd + | Pcmoveil _ -> Cmoved + | Pcmoveuil _ -> Cmoved + +let arith_ri32_real = Make + +let arith_ri64_real = Make + +let arith_rf32_real = Make + +let arith_rf64_real = Make + +let store_real = function + | Psb -> Sb + | Psh -> Sh + | Psw -> Sw + | Psw_a -> Sw + | Psd -> Sd + | Psd_a -> Sd + | Pfss -> Sw + | Pfsd -> Sd + +let load_real = function + | Plb -> Lbs + | Plbu -> Lbz + | Plh -> Lhs + | Plhu -> Lhz + | Plw -> Lws + | Plw_a -> Lws + | Pld -> Ld + | Pld_a -> Ld + | Pfls -> Lws + | Pfld -> Ld + +let set_real = Set +let get_real = Get +let nop_real = Nop +let loadsymbol_real = Make +let loadqrro_real = Lq +let loadorro_real = Lo +let storeqrro_real = Sq +let storeorro_real = So + +let ret_real = Ret +let call_real = Call +let icall_real = Icall +let goto_real = Goto +let igoto_real = Igoto +let jl_real = Goto +let cb_real = Cb +let cbu_real = Cb + +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false } + +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false } + +let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false} + +let arith_arri32_rec i rd rs imm32 = { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } + +let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } + +let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false} + +let arith_arrr_rec i rd rs1 rs2 = { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false} + +let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false} let arith_r_rec i rd = match i with (* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *) - | Ploadsymbol (id, ofs) -> { inst = "Ploadsymbol"; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false} + | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false} let arith_rec i = match i with @@ -228,45 +262,45 @@ let arith_rec i = | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) - | PArithRI32 (rd, imm32) -> { inst = arith_ri32_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} - | PArithRF32 (rd, f) -> { inst = arith_rf32_str; write_locs = [Reg (IR rd)]; read_locs = []; + | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} + | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false} - | PArithRF64 (rd, f) -> { inst = arith_rf64_str; write_locs = [Reg (IR rd)]; read_locs = []; + | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false} | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with | PLoadRRO (i, rs1, rs2, imm) -> - { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} | PLoadQRRO(rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = "Plq"; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} + { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} | PLoadORRO(rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = "Plo"; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} + { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> - { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} let store_rec i = match i with | PStoreRRO (i, rs1, rs2, imm) -> - { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} | PStoreQRRO (rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = "Psq"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)) + { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} | PStoreORRO (rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = "Pso"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; imm = (Some (Off imm)) + { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} - | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None + | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} -let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } +let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } -let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false } +let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false } let basic_rec i = match i with @@ -277,20 +311,20 @@ let basic_rec i = | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs - | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false} + | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false} let expand_rec = function | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function - | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} - | Pcall lbl -> { inst = "Pcall"; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} - | Picall r -> { inst = "Picall"; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} - | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pigoto r -> { inst = "Pigoto"; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} - | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} + | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} + | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} + | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} + | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} + | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} + | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} + | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} + | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) let control_rec i = @@ -473,139 +507,22 @@ let lsu_data_y : int array = let resmap = fun r -> match r with (** Real instructions *) -type real_instruction = - (* ALU *) - | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw - | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Srsd | Xord - | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd - | Maddw | Maddd | Msbfw | Msbfd | Cmoved - | Make | Nop | Extfz | Extfs | Insf - | Addxw | Addxd - (* LSU *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo - | Sb | Sh | Sw | Sd | Sq | So - (* BCU *) - | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set - (* FPU *) - | Fabsd | Fabsw | Fnegw | Fnegd - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz - | Fcompw | Fcompd - -let ab_inst_to_real = function - | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw - | "Paddxw" | "Paddxiw" -> Addxw - | "Paddxl" | "Paddxil" -> Addxd - | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd - | "Pandw" | "Pandiw" -> Andw - | "Pnandw" | "Pnandiw" -> Nandw - | "Pandl" | "Pandil" -> Andd - | "Pnandl" | "Pnandil" -> Nandd - | "Pcompw" | "Pcompiw" -> Compw - | "Pcompl" | "Pcompil" -> Compd - | "Pfcompw" -> Fcompw - | "Pfcompl" -> Fcompd - | "Pmulw" | "Pmuliw" -> Mulw - | "Pmull" | "Pmulil" -> Muld - | "Porw" | "Poriw" -> Orw - | "Pnorw" | "Pnoriw" -> Norw - | "Porl" | "Poril" -> Ord - | "Pnorl" | "Pnoril" -> Nord - | "Psubw" | "Pnegw" -> Sbfw - | "Psubl" | "Pnegl" -> Sbfd - | "Psraw" | "Psraiw" -> Sraw - | "Psral" | "Psrail" -> Srad - | "Psrxw" | "Psrxiw" -> Srsw - | "Psrxl" | "Psrxil" -> Srsd - | "Psrlw" | "Psrliw" -> Srlw - | "Psrll" | "Psrlil" -> Srld - | "Psllw" | "Pslliw" -> Sllw - | "Proriw" -> Rorw - | "Pmaddw" | "Pmaddiw" -> Maddw - | "Pmsubw" | "Pmsubiw" -> Msbfw - | "Pslll" | "Psllil" -> Slld - | "Pxorw" | "Pxoriw" -> Xorw - | "Pnxorw" | "Pnxoriw" -> Nxorw - | "Pandnw" | "Pandniw" -> Andnw - | "Pornw" | "Porniw" -> Ornw - | "Pxorl" | "Pxoril" -> Xord - | "Pnxorl" | "Pnxoril" -> Nxord - | "Pandnl" | "Pandnil" -> Andnd - | "Pornl" | "Pornil" -> Ornd - | "Pmaddl" | "Pmaddil" -> Maddd - | "Pmsubl" | "Pmsubil" -> Msbfd - | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make - | "Pnop" | "Pcvtw2l" -> Nop - | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz - | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs - | "Pinsf" | "Pinsfl" -> Insf - | "Pfnarrowdw" -> Fnarrowdw - | "Pfwidenlwd" -> Fwidenlwd - | "Pfloatwrnsz" -> Floatwz - | "Pfloatuwrnsz" -> Floatuwz - | "Pfloatdrnsz" -> Floatdz - | "Pfloatudrnsz" -> Floatudz - | "Pfixedwrzz" -> Fixedwz - | "Pfixeduwrzz" -> Fixeduwz - | "Pfixeddrzz" -> Fixeddz - | "Pfixedudrzz" -> Fixedudz - | "Pfixeddrzz_i32" -> Fixeddz - | "Pfixedudrzz_i32" -> Fixedudz - | "Pcmove" | "Pcmoveu" | "Pcmoveiw" | "Pcmoveuiw" | "Pcmoveil" | "Pcmoveuil" -> Cmoved - - | "Plb" -> Lbs - | "Plbu" -> Lbz - | "Plh" -> Lhs - | "Plhu" -> Lhz - | "Plw" | "Plw_a" | "Pfls" -> Lws - | "Pld" | "Pfld" | "Pld_a" -> Ld - | "Plq" -> Lq - | "Plo" -> Lo - - | "Psb" -> Sb - | "Psh" -> Sh - | "Psw" | "Psw_a" | "Pfss" -> Sw - | "Psd" | "Psd_a" | "Pfsd" -> Sd - | "Psq" -> Sq - | "Pso" -> So - - | "Pcb" | "Pcbu" -> Cb - | "Pcall" | "Pdiv" | "Pdivu" -> Call - | "Picall" -> Icall - | "Pgoto" | "Pj_l" -> Goto - | "Pigoto" -> Igoto - | "Pget" -> Get - | "Pret" -> Ret - | "Pset" -> Set - - | "Pfabsd" -> Fabsd - | "Pfabsw" -> Fabsw - | "Pfnegw" -> Fnegw - | "Pfnegd" -> Fnegd - | "Pfaddd" -> Faddd - | "Pfaddw" -> Faddw - | "Pfsbfd" -> Fsbfd - | "Pfsbfw" -> Fsbfw - | "Pfmuld" -> Fmuld - | "Pfmulw" -> Fmulw - - | "nop" -> Nop - - | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s - exception InvalidEncoding let rec_to_usage r = let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i) | Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) - and real_inst = ab_inst_to_real r.inst - in match real_inst with + in match r.inst with | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw | Nxorw | Andnw | Ornw -> (match encoding with None | Some U6 | Some S10 -> alu_tiny | Some U27L5 | Some U27L10 -> alu_tiny_x | _ -> raise InvalidEncoding) + | Sbfxw | Sbfxd -> + (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord | Nxord | Andnd | Ornd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny @@ -667,11 +584,11 @@ let rec_to_usage r = let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srsw | Srlw | Sllw | Xorw + | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw (* TODO check rorw *) | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw | Nandd | Nord | Nxord | Ornd | Andnd - | Addd | Andd | Compd | Ord | Sbfd | Srad | Srsd | Srld | Slld | Xord | Make + | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 @@ -686,7 +603,7 @@ let real_inst_to_latency = function let rec_to_info r : inst_info = let usage = rec_to_usage r - and latency = real_inst_to_latency @@ ab_inst_to_real r.inst + and latency = real_inst_to_latency r.inst in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) -- cgit From c57baa03fa83d1295a3ba622986a02bd2fa6476f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 18 Jul 2019 17:32:46 +0200 Subject: Removing a hidden FIXME that hopefully didn't have any impact.. --- mppa_k1c/PostpassSchedulingOracle.ml | 7 ------- 1 file changed, 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index af66bdb6..895f9f40 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -912,10 +912,3 @@ let schedule bb = (* print_problem (build_problem bb); *) if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb -(** FIXME - Fix for PostpassScheduling WIP *) - -type bblock' = int - -let trans_block bb = 1 - -let bblock_equivb' bb1 bb2 = true -- cgit From 4c379d48b35e7c8156f3953fede31d5e47faf8ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 19 Jul 2019 18:59:44 +0200 Subject: helpers broke compilation --- mppa_k1c/Archi.v | 36 ++++++++++++++++++++++++------------ mppa_k1c/Builtins1.v | 33 +++++++++++++++++++++++++++++++++ mppa_k1c/SelectOp.vp | 3 +++ 3 files changed, 60 insertions(+), 12 deletions(-) create mode 100644 mppa_k1c/Builtins1.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 113f5d51..800c9fe5 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -16,7 +16,7 @@ (** Architecture-dependent parameters for RISC-V *) -Require Import ZArith. +Require Import ZArith List. (*From Flocq*) Require Import Binary Bits. @@ -34,6 +34,8 @@ Proof. unfold splitlong. destruct ptr64; simpl; congruence. Qed. +(** THIS IS NOT CHECKED ! NONE OF THIS ! *) + (** Section 7.3: "Except when otherwise stated, if the result of a floating-point operation is NaN, it is the canonical NaN. The canonical NaN has a positive sign and all significand bits clear @@ -41,26 +43,36 @@ Qed. We need to extend the [choose_binop_pl] functions to account for this case. *) -Definition default_nan_64 : { x : binary64 | is_nan _ _ x = true } := - exist _ (B754_nan 53 1024 true (iter_nat 51 _ xO xH) (eq_refl true)) (eq_refl true). +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). -Definition choose_binop_pl_64 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +(* Always choose the first NaN argument, if any *) -Definition default_nan_32 : { x : binary32 | is_nan _ _ x = true } := - exist _ (B754_nan 24 128 true (iter_nat 22 _ xO xH) (eq_refl true)) (eq_refl true). +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. -Definition choose_binop_pl_32 (pl1 pl2 : positive) := - false. (**r always choose first NaN *) +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. -(* TODO check *) Definition fpu_returns_default_qNaN := false. +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, z, y). + +Definition fma_invalid_mul_is_nan := false. Definition float_of_single_preserves_sNaN := false. Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_binop_pl_64 - default_nan_32 choose_binop_pl_32 + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. (** Whether to generate position-independent code or not *) diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v new file mode 100644 index 00000000..f6e643d2 --- /dev/null +++ b/mppa_k1c/Builtins1.v @@ -0,0 +1,33 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, Collège de France and Inria Paris *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values. +Require Import Builtins0. + +Inductive platform_builtin : Type := . + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := + match b with end. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 3df0c682..688820b3 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -54,6 +54,7 @@ Require Import OpHelpers. Require Import ExtValues. Require Import DecBoolOps. Require Import Chunks. +Require Import Builtins. Require Compopts. Local Open Scope cminorsel_scope. @@ -673,6 +674,8 @@ Definition divfs_base (e1: expr) (e2: expr) := Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). End SELECT. +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + None. (* Local Variables: *) (* mode: coq *) (* End: *) \ No newline at end of file -- cgit From 780ad9d001af651a49d7470e963ed9a49ee11a4c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 19 Jul 2019 19:49:46 +0200 Subject: various fixes --- mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/CBuiltins.ml | 4 ++-- mppa_k1c/SelectOpproof.v | 15 +++++++++++++++ mppa_k1c/TargetPrinter.ml | 4 +++- 4 files changed, 22 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 65dee6c7..556fac9a 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -467,11 +467,11 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pdzerol addr) | "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res - then (emit (Pmv(res, incr_res)); emit Psemi)); + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); emit (Pafaddd(addr, res)) | "__builtin_k1_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res - then (emit (Pmv(res, incr_res)); emit Psemi)); + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); emit (Pafaddw(addr, res)) | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> emit (Palclrd(res, addr)) diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 2f80c90f..09a9ba97 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -18,11 +18,11 @@ open C let builtins = { - Builtins.typedefs = [ + builtin_typedefs = [ "__builtin_va_list", TPtr(TVoid [], []) ]; (* The builtin list is inspired from the GCC file builtin_k1.h *) - Builtins.functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) + builtin_functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) (* BCU Instructions *) "__builtin_k1_await", (TVoid [], [], false); (* DONE *) "__builtin_k1_barrier", (TVoid [], [], false); (* DONE *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 21a06857..e009ed98 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -17,6 +17,7 @@ (** Correctness of instruction selection for operators *) +Require Import Builtins. Require Import Coqlib. Require Import Maps. Require Import AST. @@ -29,6 +30,7 @@ Require Import Globalenvs. Require Import Cminor. Require Import Op. Require Import CminorSel. +Require Import Builtins1. Require Import SelectOp. Require Import Events. Require Import OpHelpers. @@ -1629,4 +1631,17 @@ Proof. intros; unfold divfs_base. econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. + +(** Platform-specific known builtins *) + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + intros. discriminate. +Qed. + End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 674695d9..dafad7fb 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -140,6 +140,8 @@ module Target (*: TARGET*) = | RA -> output_string oc "$ra" | _ -> assert false + let preg_asm oc ty = preg oc + let preg_annot = let open Asmvliw in function | IR r -> int_reg_name r | RA -> "$ra" @@ -324,7 +326,7 @@ module Target (*: TARGET*) = (P.to_int kind) (extern_atom txt) args | EF_inline_asm(txt, sg, clob) -> fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | _ -> assert false -- cgit From 34c136fcd0ffcfe61e3cec5c72a90a1d3bcdc941 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 22 Jul 2019 18:38:49 +0200 Subject: (#137) [BROKEN] - Finer latencies for the oracle. Some debugging to do --- mppa_k1c/PostpassSchedulingOracle.ml | 133 ++++++++++++++++++++++++----------- 1 file changed, 93 insertions(+), 40 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 895f9f40..b9fc3c18 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -38,6 +38,8 @@ type ab_inst_rec = { inst: real_instruction; write_locs : location list; read_locs : location list; + read_at_id : location list; (* Must be contained in read_locs *) + read_at_e1 : location list; (* idem *) imm : immediate option; is_control : bool; } @@ -232,25 +234,40 @@ let jl_real = Goto let cb_real = Cb let cbu_real = Cb -let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false } +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false; + read_at_id = []; read_at_e1 = [] } -let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false } +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = [] } -let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false} +let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } -let arith_arri32_rec i rd rs imm32 = { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false } +let arith_arri32_rec i rd rs imm32 = + let rae1 = match i with Pmaddiw -> [Reg rd] | _ -> [] + in { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false; + read_at_id = [] ; read_at_e1 = rae1 } -let arith_arri64_rec i rd rs imm64 = { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false } +let arith_arri64_rec i rd rs imm64 = + let rae1 = match i with Pmaddil -> [Reg rd] | _ -> [] + in { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = rae1 } -let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false} +let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } -let arith_arrr_rec i rd rs1 rs2 = { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false} +let arith_arrr_rec i rd rs1 rs2 = + let rae1 = match i with Pmaddl | Pmaddw | Pmsubl | Pmsubw -> [Reg rd] | _ -> [] + in { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = rae1 } -let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false} +let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } let arith_r_rec i rd = match i with (* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *) - | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false} + | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); + is_control = false; read_at_id = []; read_at_e1 = [] } let arith_rec i = match i with @@ -262,45 +279,54 @@ let arith_rec i = | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) - | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false} - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false} + | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false} + imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false} + imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with | PLoadRRO (i, rs1, rs2, imm) -> - { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false} + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } | PLoadQRRO(rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} + { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } | PLoadORRO(rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false} + { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; + imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> - { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false} + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; + read_at_id = []; read_at_e1 = [] } let store_rec i = match i with - | PStoreRRO (i, rs1, rs2, imm) -> - { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm)) - ; is_control = false} + | PStoreRRO (i, rs, ra, imm) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs)] ; is_control = false} | PStoreQRRO (rs, ra, imm) -> let (rs0, rs1) = gpreg_q_expand rs in - { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)) - ; is_control = false} + { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1)] ; is_control = false} | PStoreORRO (rs, ra, imm) -> let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; imm = (Some (Off imm)) - ; is_control = false} - | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None - ; is_control = false} + { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; + imm = (Some (Off imm)); read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; is_control = false} + | PStoreRRR (i, rs, ra1, ra2) | PStoreRRRXS (i, rs, ra1, ra2) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra1); Reg (IR ra2)]; imm = None; + read_at_id = []; read_at_e1 = [Reg (IR rs)]; is_control = false} -let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false } +let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } -let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false } +let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } let basic_rec i = match i with @@ -311,20 +337,24 @@ let basic_rec i = | Pfreeframe (_, _) -> raise OpaqueInstruction | Pget (rd, rs) -> get_rec rd rs | Pset (rd, rs) -> set_rec rd rs - | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false} + | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []} let expand_rec = function | Pbuiltin _ -> raise OpaqueInstruction let ctl_flow_rec = function - | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true} - | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true} - | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true} - | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true} - | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true} - | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} - | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true} + | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []} + | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) let control_rec i = @@ -350,6 +380,8 @@ let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) type inst_info = { write_locs : location list; read_locs : location list; + reads_at_id : bool; + reads_at_e1 : bool; is_control : bool; usage: int array; (* resources consumed by the instruction *) latency: int; @@ -582,6 +614,16 @@ let rec_to_usage r = | Fnarrowdw -> alu_full | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau +let inst_info_to_dlatency i = + begin + assert (not (i.reads_at_id && i.reads_at_e1)); + match i.reads_at_id with + | true -> +1 + | false -> (match i.reads_at_e1 with + | true -> -1 + | false -> 0) + end + let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw @@ -601,10 +643,17 @@ let real_inst_to_latency = function | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 4 +let rec empty_inter la = function + | [] -> true + | b::lb -> if (List.mem b la) then false else empty_inter la lb + let rec_to_info r : inst_info = let usage = rec_to_usage r and latency = real_inst_to_latency r.inst - in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control } + and reads_at_id = not (empty_inter r.read_locs r.read_at_id) + and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1) + in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control; + reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 } let instruction_infos bb = List.map rec_to_info (instruction_recs bb) @@ -651,6 +700,8 @@ let rec get_accesses hashloc (ll: location list) = match ll with | [] -> [] | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) +let compute_latency (ifrom: inst_info) (ito: inst_info) = ifrom.latency + (inst_info_to_dlatency ito) + let latency_constraints bb = let written = LocHash.create 70 and read = LocHash.create 70 @@ -662,8 +713,10 @@ let latency_constraints bb = and waw = get_accesses written i.write_locs and war = get_accesses read i.write_locs in begin - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) raw; - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = (List.nth instr_infos i).latency} :: !constraints) waw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw; List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); (* Updating "read" and "written" hashmaps *) -- cgit From 4c1209c5c1e0e667f20f13bc02662fdc7e4868ac Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 23 Jul 2019 10:42:47 +0200 Subject: (#137) Possible fix --- mppa_k1c/PostpassSchedulingOracle.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index b9fc3c18..fd03a80c 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -700,7 +700,10 @@ let rec get_accesses hashloc (ll: location list) = match ll with | [] -> [] | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) -let compute_latency (ifrom: inst_info) (ito: inst_info) = ifrom.latency + (inst_info_to_dlatency ito) +let compute_latency (ifrom: inst_info) (ito: inst_info) = + let dlat = inst_info_to_dlatency ito + in let lat = ifrom.latency + dlat + in assert (lat >= 0); if (lat == 0) then 1 else lat let latency_constraints bb = let written = LocHash.create 70 -- cgit From 7da1af080217eef5626480ac30feda45ff8ca002 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Jul 2019 11:01:37 +0200 Subject: (#144) Fixing on RTL dumps --- mppa_k1c/Op.v | 20 ++++++++--------- mppa_k1c/PrintOp.ml | 63 ++++++++++++++++++++++++++++++++++------------------- 2 files changed, 50 insertions(+), 33 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 35fbb596..815d3958 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -100,23 +100,23 @@ Inductive operation : Type := | Onandimm (n: int) (**r [rd = ~(r1 & n)] *) | Oor (**r [rd = r1 | r2] *) | Oorimm (n: int) (**r [rd = r1 | n] *) - | Onor (**r [rd = r1 | r2] *) - | Onorimm (n: int) (**r [rd = r1 | n] *) + | Onor (**r [rd = ~(r1 | r2)] *) + | Onorimm (n: int) (**r [rd = ~(r1 | n)] *) | Oxor (**r [rd = r1 ^ r2] *) | Oxorimm (n: int) (**r [rd = r1 ^ n] *) | Onxor (**r [rd = ~(r1 ^ r2)] *) | Onxorimm (n: int) (**r [rd = ~(r1 ^ n)] *) | Onot (**r [rd = ~r1] *) - | Oandn (**r [rd = (~r1) ^ r2] *) - | Oandnimm (n: int) (**r [rd = (~r1) ^ n] *) + | Oandn (**r [rd = (~r1) & r2] *) + | Oandnimm (n: int) (**r [rd = (~r1) & n] *) | Oorn (**r [rd = (~r1) | r2] *) | Oornimm (n: int) (**r [rd = (~r1) | n] *) | Oshl (**r [rd = r1 << r2] *) | Oshlimm (n: int) (**r [rd = r1 << n] *) - | Oshr (**r [rd = r1 >> r2] (signed) *) - | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *) - | Oshru (**r [rd = r1 >> r2] (unsigned) *) - | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshr (**r [rd = r1 >>s r2] (signed) *) + | Oshrimm (n: int) (**r [rd = r1 >>s n] (signed) *) + | Oshru (**r [rd = r1 >>u r2] (unsigned) *) + | Oshruimm (n: int) (**r [rd = r1 >>x n] (unsigned) *) | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) | Ororimm (n: int) (**r rotate right immediate *) | Omadd (**r [rd = rd + r1 * r2] *) @@ -158,8 +158,8 @@ Inductive operation : Type := | Onxorl (**r [rd = ~(r1 ^ r2)] *) | Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *) | Onotl (**r [rd = ~r1] *) - | Oandnl (**r [rd = (~r1) ^ r2] *) - | Oandnlimm (n: int64) (**r [rd = (~r1) ^ n] *) + | Oandnl (**r [rd = (~r1) & r2] *) + | Oandnlimm (n: int64) (**r [rd = (~r1) & n] *) | Oornl (**r [rd = (~r1) | r2] *) | Oornlimm (n: int64) (**r [rd = (~r1) | n] *) | Oshll (**r [rd = r1 << r2] *) diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 575fa94f..7c408cdf 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -72,7 +72,7 @@ let int_of_s14 = function | SHIFT3 -> 3 | SHIFT4 -> 4 -let print_operation reg pp = function +let print_operation reg pp op = match op with | Omove, [r1] -> reg pp r1 | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) @@ -86,9 +86,15 @@ let print_operation reg pp = function | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Orevsubimm(imm), [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 + | Orevsubx(s14), [r1; r2] -> fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) | Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2 | Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2 | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 @@ -101,6 +107,13 @@ let print_operation reg pp = function | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Onxor, [r1;r2] -> fprintf pp "~(%a ^ %a)" reg r1 reg r2 + | Onxorimm n, [r1] -> fprintf pp "~(%a ^ %ld)" reg r1 (camlint_of_coqint n) + | Onot, [r1] -> fprintf pp "~%a" reg r1 + | Oandn, [r1; r2] -> fprintf pp "(~%a) & %a" reg r1 reg r2 + | Oandnimm n, [r1] -> fprintf pp "(~%a) & %ld" reg r1 (camlint_of_coqint n) + | Oorn, [r1;r2] -> fprintf pp "(~%a) | %a" reg r1 reg r2 + | Oornimm n, [r1] -> fprintf pp "(~%a) | %ld" reg r1 (camlint_of_coqint n) | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 @@ -108,6 +121,10 @@ let print_operation reg pp = function | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Ororimm n, [r1] -> fprintf pp "(%a ror %ld)" reg r1 (camlint_of_coqint n) + | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 + | Omaddimm imm, [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) + | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 @@ -116,9 +133,15 @@ let print_operation reg pp = function | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) + | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%Ld -l (%a < fprintf pp "-l (%a)" reg r1 | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 + | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) | Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2 | Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2 | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 @@ -129,8 +152,17 @@ let print_operation reg pp = function | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Onorl, [r1; r2] -> fprintf pp "~(%a |l %a)" reg r1 reg r2 + | Onorlimm n, [r1] -> fprintf pp "~(%a |l %Ld)" reg r1 (camlint64_of_coqint n) | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Onxorl, [r1;r2] -> fprintf pp "~(%a ^l %a)" reg r1 reg r2 + | Onxorlimm n, [r1] -> fprintf pp "~(%a ^l %Ld)" reg r1 (camlint64_of_coqint n) + | Onotl, [r1] -> fprintf pp "~%a" reg r1 + | Oandnl, [r1;r2] -> fprintf pp "(~%a) &l %a" reg r1 reg r2 + | Oandnlimm n, [r1] -> fprintf pp "(~%a) &l %Ld" reg r1 (camlint64_of_coqint n) + | Oornl, [r1;r2] -> fprintf pp "(~%a) |l %a" reg r1 reg r2 + | Oornlimm n, [r1;r2] -> fprintf pp "(~%a) |l %Ld" reg r1 (camlint64_of_coqint n) | Oshll, [r1;r2] -> fprintf pp "%a < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 @@ -138,6 +170,9 @@ let print_operation reg pp = function | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 + | Omaddlimm imm, [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) + | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 @@ -155,14 +190,14 @@ let print_operation reg pp = function | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 - | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 - | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 - | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 - | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 @@ -184,24 +219,6 @@ let print_operation reg pp = function | Osellimm(cond0, imm), [r1; rc] -> print_condition0 reg pp cond0 rc; fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) - | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 - | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) - | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 - | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) - | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 - | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a < fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) - | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) - | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) - | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 - | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 - | (Omaddimm imm), [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) - | (Omaddlimm imm), [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) - | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 - | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 | _, _ -> fprintf pp "" let print_addressing reg pp = function -- cgit From a11f3b87e0535b6c7953c74d00d91fb7d7fbb21b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 24 Jul 2019 11:05:56 +0200 Subject: (#145) Fix on RTL dumps --- mppa_k1c/PrintOp.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 7c408cdf..67f87000 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -222,8 +222,9 @@ let print_operation reg pp op = match op with | _, _ -> fprintf pp "" let print_addressing reg pp = function - | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) + | Aindexed2XS scale, [r1;r2] -> fprintf pp "%a + (%a << %ld)" reg r1 reg r2 (camlint_of_coqint scale) | Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) | Aglobal(id, ofs), [] -> fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) -- cgit From 98c22a6f37c7230faf80b6366aaa1c2476f9e67c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 25 Jul 2019 14:29:28 +0200 Subject: (#139) - Mise à jour du code Coq, oracle MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/PostpassScheduling.v | 55 ++++++++++++++++++++++++++++++------ mppa_k1c/PostpassSchedulingOracle.ml | 14 +++++++-- mppa_k1c/PostpassSchedulingproof.v | 2 +- 3 files changed, 59 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 15cb4c48..76757eba 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -19,7 +19,7 @@ Local Open Scope error_monad_scope. (** Oracle taking as input a basic block, returns a schedule expressed as a list of bundles *) -Axiom schedule: bblock -> list bblock. +Axiom schedule: bblock -> (list (list basic)) * option control. Extract Constant schedule => "PostpassSchedulingOracle.schedule". @@ -333,10 +333,49 @@ Proof. apply stick_header_concat_all. assumption. Qed. +Program Definition make_bblock_from_basics lb := + match lb with + | nil => Error (msg "PostpassScheduling.make_bblock_from_basics") + | b :: lb => OK {| header := nil; body := b::lb; exit := None |} + end. + +Fixpoint schedule_to_bblocks_nocontrol llb := + match llb with + | nil => OK nil + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_nocontrol llb; + OK (bb :: lbb) + end. +Program Definition make_bblock_from_basics_and_control lb c := + match c with + | PExpand (Pbuiltin _ _ _) => Error (msg "PostpassScheduling.make_bblock_from_basics_and_control") + | PCtlFlow cf => OK {| header := nil; body := lb; exit := Some (PCtlFlow cf) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - right. discriminate. + - discriminate. +Qed. + +Fixpoint schedule_to_bblocks_wcontrol llb c := + match llb with + | nil => OK ((bblock_single_inst (PControl c)) :: nil) + | lb :: nil => do bb <- make_bblock_from_basics_and_control lb c; OK (bb :: nil) + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_wcontrol llb c; + OK (bb :: lbb) + end. + +Definition schedule_to_bblocks (llb: list (list basic)) (oc: option control) : res (list bblock) := + match oc with + | None => schedule_to_bblocks_nocontrol llb + | Some c => schedule_to_bblocks_wcontrol llb c + end. -Definition do_schedule (bb: bblock) : list bblock := - if (Z.eqb (size bb) 1) then bb::nil else schedule bb. +Definition do_schedule (bb: bblock) : res (list bblock) := + if (Z.eqb (size bb) 1) then OK (bb::nil) + else match (schedule bb) with (llb, oc) => schedule_to_bblocks llb oc end. Definition verify_par_bblock (bb: bblock) : res unit := if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock"). @@ -350,7 +389,7 @@ Fixpoint verify_par (lbb: list bblock) := Definition verified_schedule_nob (bb : bblock) : res (list bblock) := let bb' := no_header bb in let bb'' := Peephole.optimize_bblock bb' in - let lbb := do_schedule bb'' in + do lbb <- do_schedule bb''; do tbb <- concat_all lbb; do sizecheck <- verify_size bb lbb; do schedcheck <- verify_schedule bb' tbb; @@ -363,7 +402,7 @@ Lemma verified_schedule_nob_size: Proof. intros. monadInv H. erewrite <- stick_header_code_size; eauto. apply verify_size_size. - destruct x0; try discriminate. assumption. + destruct x1; try discriminate. assumption. Qed. Lemma verified_schedule_nob_no_header_in_middle: @@ -382,7 +421,7 @@ Lemma verified_schedule_nob_header: /\ Forall (fun b => header b = nil) lbb. Proof. intros. split. - - monadInv H. unfold stick_header_code in EQ2. destruct (hd_error _); try discriminate. inv EQ2. + - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. simpl. reflexivity. - apply verified_schedule_nob_no_header_in_middle in H. assumption. Qed. @@ -435,8 +474,8 @@ Proof. exploit stick_header_code_concat_all; eauto. intros (tbb & CONC & STH). exists tbb. split; auto. - rewrite verify_schedule_no_header in EQ0. erewrite stick_header_verify_schedule in EQ0; eauto. - eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ0. + rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto. + eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2. destruct (bblock_simub _ _); auto; try discriminate. Qed. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fd03a80c..40f1d9c7 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -961,10 +961,18 @@ let smart_schedule bb = in bundles @ (f lbb) in f lbb -(** Called schedule function from Coq *) - -let schedule bb = +let bblock_to_bundles bb = if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); (* print_problem (build_problem bb); *) if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb +(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *) + +let rec bundles_to_coq_schedule = function + | [] -> ([], None) + | bb :: [] -> ([bb.body], bb.exit) + | bb :: lbb -> let (llb, oc) = bundles_to_coq_schedule lbb in (bb.body :: llb, oc) + +(** Called schedule function from Coq *) + +let schedule bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 5d4fc881..0edaf4e2 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -798,7 +798,7 @@ Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: List.In bundle lb -> verify_par_bblock bundle = OK tt. Proof. unfold verified_schedule_nob. intros H; - monadInv H. destruct x3. + monadInv H. destruct x4. intros; eapply verified_par_checks_alls_bundles; eauto. Qed. -- cgit From 211382d21013c038c3c716454fcfa5a375dba8ba Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 11:15:15 +0200 Subject: (#139) - Predicate is_concat --- mppa_k1c/PostpassScheduling.v | 15 ++++++++------- mppa_k1c/PostpassSchedulingproof.v | 2 +- 2 files changed, 9 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 76757eba..8b6de1e2 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -208,7 +208,8 @@ Proof. + apply IHlbb in EQ. assumption. Qed. - +Inductive is_concat : bblock -> list bblock -> Prop := + | mk_is_concat: forall tbb lbb, concat_all lbb = OK tbb -> is_concat tbb lbb. Definition verify_schedule (bb bb' : bblock) : res unit := match bblock_simub bb bb' with @@ -466,14 +467,14 @@ Qed. Lemma verified_schedule_nob_correct: forall ge f bb lbb, verified_schedule_nob bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb + exists tbb, + is_concat tbb lbb /\ bblock_simu ge f bb tbb. Proof. intros. monadInv H. exploit stick_header_code_concat_all; eauto. intros (tbb & CONC & STH). - exists tbb. split; auto. + exists tbb. split; auto. constructor; auto. rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto. eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2. destruct (bblock_simub _ _); auto; try discriminate. @@ -482,13 +483,13 @@ Qed. Theorem verified_schedule_correct: forall ge f bb lbb, verified_schedule bb = OK lbb -> - exists tbb, - concat_all lbb = OK tbb + exists tbb, + is_concat tbb lbb /\ bblock_simu ge f bb tbb. Proof. intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. all: try (eapply verified_schedule_nob_correct; eauto; fail). - inv H. eexists. split; simpl; auto. constructor; auto. + inv H. eexists. split; simpl; auto. constructor; auto. simpl; auto. constructor; auto. Qed. Lemma verified_schedule_builtin_idem: diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 0edaf4e2..2207a2fa 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -736,7 +736,7 @@ Proof. induction 1; intros; inv MS. - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). - exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). + exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). inv CONC. rename H3 into CONC. assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). eapply transf_function_no_overflow; eauto. -- cgit From 5b4560bd853cbcf1ef195da1b625f37609ec00ec Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 11:33:51 +0200 Subject: (#139) - Quelques renommages --- mppa_k1c/Asmblock.v | 2 +- mppa_k1c/Asmblockdeps.v | 10 +++++----- mppa_k1c/Asmvliw.v | 8 ++++---- mppa_k1c/PostpassSchedulingproof.v | 4 ++-- 4 files changed, 12 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index ddb7ce7d..0a25e81a 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -286,7 +286,7 @@ Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: (** * basic instructions *) -Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := parexec_basic_instr ge bi rs rs m m. +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := bstep ge bi rs rs m m. Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := match body with diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9855afa2..a7fa5cff 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -846,7 +846,7 @@ Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - match_outcome (parexec_basic_instr ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). + match_outcome (bstep ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). Proof. (* a little tactic to automate reasoning on preg_eq *) @@ -1004,7 +1004,7 @@ Proof. induction bdy as [|i bdy]; simpl; eauto. intros. exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. - destruct (parexec_basic_instr _ _ _ _ _ _); simpl. + destruct (bstep _ _ _ _ _ _); simpl. - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - intros X; rewrite X; simpl; auto. Qed. @@ -1015,7 +1015,7 @@ Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: match_states (State rsw mw) sw -> match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) (rsw#PC <- aux) mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. - intros GENV MSR MSW; unfold parexec_exit. + intros GENV MSR MSW; unfold estep. simpl in *. inv MSR. inv MSW. destruct ex. - destruct c; destruct i; try discriminate; simpl. @@ -1071,9 +1071,9 @@ Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: Ge = Genv ge fn -> match_states (State rsr mr) sr -> match_states (State rsw mw) sw -> - match_outcome (parexec_exit ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). + match_outcome (estep ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). Proof. - intros; unfold parexec_exit. + intros; unfold estep. exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. apply extensionality. intros; destruct x; simpl; auto. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c5b7db45..c6dd85f4 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1355,7 +1355,7 @@ Definition store_chunk n := (** * basic instructions *) -Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) := +Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := match bi with | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw @@ -1414,7 +1414,7 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := match body with | nil => Next rsw mw | bi::body' => - match parexec_basic_instr bi rsr rsw mr mw with + match bstep bi rsr rsw mr mw with | Next rsw mw => parexec_wio_body body' rsr rsw mr mw | Stuck => Stuck end @@ -1550,12 +1550,12 @@ Definition incrPC size_b (rs: regset) := rs#PC <- (Val.offset_ptr rs#PC size_b). (** parallel execution of the exit instruction of a bundle *) -Definition parexec_exit (f: function) ext size_b (rsr rsw: regset) (mw: mem) +Definition estep (f: function) ext size_b (rsr rsw: regset) (mw: mem) := parexec_control f ext (incrPC size_b rsr) rsw mw. Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome := match parexec_wio_body bdy rs rs m m with - | Next rsw mw => parexec_exit f ext size_b rs rsw mw + | Next rsw mw => estep f ext size_b rs rsw mw | Stuck => Stuck end. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 2207a2fa..21af276b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -240,7 +240,7 @@ Lemma exec_basic_instr_pc_var: exec_basic_instr ge i rs m = Next rs' m' -> exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. Proof. - intros. unfold exec_basic_instr in *. unfold parexec_basic_instr in *. destruct i. + intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. - unfold exec_arith_instr in *. destruct i; destruct i. all: try (exploreInst; inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). @@ -681,7 +681,7 @@ Lemma transf_exec_basic_instr: forall i rs m, exec_basic_instr ge i rs m = exec_basic_instr tge i rs m. Proof. intros. pose symbol_address_preserved. - unfold exec_basic_instr. unfold parexec_basic_instr. exploreInst; simpl; auto; try congruence. + unfold exec_basic_instr. unfold bstep. exploreInst; simpl; auto; try congruence. unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. Qed. -- cgit From ce33586e40bf7be637b932d363275b9d5761a3a0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 30 Jul 2019 16:46:16 +0200 Subject: (#156) - Un peu de cleaning et de doc --- mppa_k1c/Archi.v | 3 +- mppa_k1c/Asm.v | 50 ++------- mppa_k1c/Asmaux.v | 2 +- mppa_k1c/Asmblock.v | 33 +----- mppa_k1c/Asmblockdeps.v | 35 +++--- mppa_k1c/Asmblockgen.v | 66 ++---------- mppa_k1c/Asmblockgenproof0.v | 86 ++------------- mppa_k1c/Asmblockgenproof1.v | 246 +------------------------------------------ mppa_k1c/Asmgenproof.v | 4 +- mppa_k1c/Asmvliw.v | 25 +---- 10 files changed, 53 insertions(+), 497 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 113f5d51..96571841 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -14,10 +14,9 @@ (* *) (* *********************************************************************) -(** Architecture-dependent parameters for RISC-V *) +(** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) Require Import ZArith. -(*From Flocq*) Require Import Binary Bits. Definition ptr64 := true. diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 620aa91e..1964e5f8 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -15,7 +15,13 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for K1c assembly language. *) +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) Require Import Coqlib. Require Import Maps. @@ -57,10 +63,6 @@ Inductive instruction : Type := | Psemi (**r semi colon separating bundles *) | Pnop (**r instruction that does nothing *) - (** builtins *) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - (** Control flow instructions *) | Pget (rd: ireg) (rs: preg) (**r get system register *) | Pset (rd: preg) (rs: ireg) (**r set system register *) @@ -101,6 +103,8 @@ Inductive instruction : Type := | Pafaddw (addr: ireg) (incr_res: ireg) | Palclrd (dst: ireg) (addr: ireg) | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) (** Loads **) | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) @@ -571,12 +575,6 @@ Definition genv := Genv.t fundef unit. Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). -(* -Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_proj fu. - -Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p. - *) - Definition fundef_proj (fu: fundef) : Asmvliw.fundef := match fu with | Internal f => Internal (function_proj f) @@ -650,35 +648,6 @@ Proof. rewrite transf_function_proj. auto. Qed. -(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit := - match gd with - | Gfun f => Gfun (transf_fundef f) - | Gvar gu => Gvar gu - end. - -Lemma transf_globdef_proj: forall gd, globdef_proj (transf_globdef gd) = gd. -Proof. - intros gd. destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj; auto. -Qed. - -Fixpoint transf_prog_defs (l: list (ident * globdef Asmblock.fundef unit)) - : list (ident * globdef fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, transf_globdef gd) :: transf_prog_defs l - end. - -Lemma transf_prog_proj: forall p, prog_defs p = prog_defs_proj (transf_prog_defs (prog_defs p)). -Proof. - intros p. destruct p as [defs pub main]. simpl. - induction defs; simpl; auto. - destruct a as [i gd]. simpl. - rewrite transf_globdef_proj. - congruence. -Qed. - *) - Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), @@ -716,7 +685,6 @@ Proof. intros. congruence. Qed. -(* I think it is a special case of Asmblock -> Asm. Very handy to have *) Lemma match_program_transf: forall p tp, match_prog p tp -> transf_program p = tp. Proof. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 85359658..94b39f4e 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -1,5 +1,5 @@ Require Import Asm. Require Import AST. -(* Constant only needed by Asmexpandaux.ml *) +(** Constant only needed by Asmexpandaux.ml *) Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 0a25e81a..9b4489c5 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -15,7 +15,7 @@ (* *) (* *********************************************************************) -(** Abstract syntax and semantics for K1c assembly language. *) +(** Sequential block semantics for K1c assembly. The syntax is given in AsmVLIW *) Require Import Coqlib. Require Import Maps. @@ -172,7 +172,6 @@ Proof. Qed. Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). -(* Local Obligation Tactic := bblock_auto_correct. *) Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2. Proof. @@ -250,9 +249,6 @@ Proof. intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. Qed. - - - (** * Sequential Semantics of basic blocks *) Section RELSEM. @@ -302,29 +298,8 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. -(** Evaluating a branch - -Warning: in m PC is assumed to be already pointing on the next instruction ! - -*) Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. -(** Execution of a single control-flow instruction [i] in initial state [rs] and - [m]. Return updated state. - - As above: PC is assumed to be incremented on the next block before the control-flow instruction - - For instructions that correspond tobuiltin - actual RISC-V instructions, the cases are straightforward - transliterations of the informal descriptions given in the RISC-V - user-mode specification. For pseudo-instructions, refer to the - informal descriptions given above. - - Note that we set to [Vundef] the registers used as temporaries by - the expansions of the pseudo-instructions, so that the RISC-V code - we generate cannot use those registers to hold values that must - survive the execution of the pseudo-instruction. *) - Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := @@ -368,16 +343,11 @@ Inductive step: state -> trace -> state -> Prop := step (State rs m) t (State rs' m') . - - End RELSEM. - - Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). - Definition data_preg (r: preg) : bool := match r with | RA => false @@ -386,4 +356,3 @@ Definition data_preg (r: preg) : bool := | IR _ => true | PC => false end. - diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index a7fa5cff..2d144bb6 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,3 +1,10 @@ +(** * Translation from Asmblock to AbstractBB + + We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance + AbstractBB will then define two semantics for L : a sequential, and a semantic one + We prove a bisimulation between the parallel semantics of L and AsmVLIW + From this, we also deduce a bisimulation between the sequential semantics of L and Asmblock *) + Require Import AST. Require Import Asmblock. Require Import Asmblockgenproof0. @@ -17,6 +24,8 @@ Require Import Chunks. Open Scope impure. +(** Definition of L *) + Module P<: ImpParam. Module R := Pos. @@ -459,18 +468,6 @@ Qed. Hint Resolve op_eq_correct: wlp. Global Opaque op_eq_correct. - -(* QUICK FIX WITH struct_eq *) - -(* Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2. - -Theorem op_eq_correct o1 o2: - WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. -Proof. - wlp_simplify. -Qed. -*) - End IMPPARAM. End P. @@ -550,7 +547,7 @@ Proof. - unfold ppos. unfold pmem. discriminate. Qed. -(** Inversion functions, used for debugging *) +(** Inversion functions, used for debug traces *) Definition pos_to_ireg (p: R.t) : option gpreg := match p with @@ -574,9 +571,6 @@ Definition inv_ppos (p: R.t) : option preg := end end. - -(** Traduction Asmblock -> Asmblockdeps *) - Notation "a @ b" := (Econs a b) (at level 102, right associativity). Definition trans_control (ctl: control) : inst := @@ -720,7 +714,7 @@ Proof. intros. congruence. Qed. -(** Parallelizability of a bblock (bundle) *) +(** Parallelizability test of a bblock (bundle), and bisimulation of the Asmblock and L parallel semantics *) Module PChk := ParallelChecks L PosPseudoRegSet. @@ -1162,7 +1156,7 @@ Proof. destruct (prun_iw _ _ _ _); simpl; eauto. Qed. -(* sequential execution *) +(** sequential execution *) Theorem bisimu_basic ge fn bi rs m s: Ge = Genv ge fn -> match_states (State rs m) s -> @@ -1264,7 +1258,6 @@ Qed. End SECT_PAR. - Section SECT_BBLOCK_EQUIV. Variable Ge: genv. @@ -1294,6 +1287,8 @@ Proof. * discriminate. Qed. +(** Used for debug traces *) + Definition gpreg_name (gpr: gpreg) := match gpr with | GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4") @@ -1645,4 +1640,4 @@ Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). -Qed. \ No newline at end of file +Qed. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e5b9b35a..7e415c2a 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -15,7 +15,8 @@ (* *) (* *********************************************************************) -(** Translation from Machblock to K1c assembly language (Asmblock) *) +(** * Translation from Machblock to K1c assembly language (Asmblock) + Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *) Require Archi. Require Import Coqlib Errors. @@ -41,23 +42,15 @@ Definition ireg_of (r: mreg) : res ireg := Definition freg_of (r: mreg) : res freg := match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. -(* -(** Decomposition of 32-bit integer constants. They are split into either - small signed immediates that fit in 12-bits, or, if they do not fit, - into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *) - -*) Inductive immed32 : Type := | Imm32_single (imm: int). Definition make_immed32 (val: int) := Imm32_single val. -(** Likewise, for 64-bit integer constants. *) Inductive immed64 : Type := | Imm64_single (imm: int64) . -(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *) Definition make_immed64 (val: int64) := Imm64_single val. Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). @@ -66,12 +59,6 @@ Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associ Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity). Notation "a @@ b" := (app a b) (at level 49, right associativity). -(** Smart constructors for arithmetic operations involving - a 32-bit or 64-bit integer constant. Depending on whether the - constant fits in 12 bits or not, one or several instructions - are generated as required to perform the operation - and prepended to the given instruction sequence [k]. *) - Definition loadimm32 (r: ireg) (n: int) := match make_immed32 n with | Imm32_single imm => Pmake r imm @@ -92,10 +79,6 @@ Definition orimm32 := opimm32 Porw Poriw. Definition norimm32 := opimm32 Pnorw Pnoriw. Definition xorimm32 := opimm32 Pxorw Pxoriw. Definition nxorimm32 := opimm32 Pnxorw Pnxoriw. -(* -Definition sltimm32 := opimm32 Psltw Psltiw. -Definition sltuimm32 := opimm32 Psltuw Psltiuw. -*) Definition loadimm64 (r: ireg) (n: int64) := match make_immed64 n with @@ -118,11 +101,6 @@ Definition norimm64 := opimm64 Pnorl Pnoril. Definition nandimm64 := opimm64 Pnandl Pnandil. Definition nxorimm64 := opimm64 Pnxorl Pnxoril. -(* -Definition sltimm64 := opimm64 Psltl Psltil. -Definition sltuimm64 := opimm64 Psltul Psltiul. -*) - Definition addptrofs (rd rs: ireg) (n: ptrofs) := if Ptrofs.eq_dec n Ptrofs.zero then Pmv rd rs @@ -170,19 +148,6 @@ Definition transl_opt_compuimm transl_compi c Unsigned r1 n lbl k . -(* Definition transl_opt_compuimm - (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k). *) - -(* match select_comp n c with - | Some Ceq => Pcbu BTweqz r1 lbl ::g k - | Some Cne => Pcbu BTwnez r1 lbl ::g k - | Some _ => nil (* Never happens *) - | None => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k) - end - . - *) - Definition select_compl (n: int64) (c: comparison) : option comparison := if Int64.eq n Int64.zero then match c with @@ -1052,7 +1017,7 @@ Definition make_epilogue (f: Machblock.function) (k: code) := (loadind_ptr SP f.(fn_retaddr_ofs) GPRA) ::g Pset RA GPRA ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. -(** Translation of a Mach instruction. *) +(** Translation of a Machblock instruction. *) Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) (ep: bool) (k: bcode) := @@ -1096,20 +1061,12 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co transl_cbranch cond args lbl nil | MBreturn => OK (make_epilogue f (Pret ::g nil)) - (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*) | MBjumptable arg tbl => do r <- ireg_of arg; OK (Pjumptable r tbl ::g nil) end end. -(* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme : - * transl_instr_control _ _ _ = lb ++ (ctl :: nil), où lb est une liste de basics, ctl est un control_inst - - Il faut arriver à exprimer cet aspect là ; extraire le lb, le rajouter dans le body ; et extraire le ctl - qu'on met dans le exit -*) - (** Translation of a code sequence *) Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := @@ -1120,8 +1077,7 @@ Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := | _ => false end. -(** This is the naive definition that we no longer use because it - is not tail-recursive. It is kept as specification. *) +(** This is the naive definition, which is not tail-recursive unlike the other backends *) Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := match il with @@ -1147,20 +1103,11 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_ transl_basic_rec f il it1p (fun c => OK c). *) (** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, + that the generated code contains less than [2^64] instructions, otherwise the offset part of the [PC] code pointer could wrap around, leading to incorrect executions. *) -(* Local Obligation Tactic := bblock_auto_correct. *) - -(* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) := - match c with - | nil => {| header := hd; body := Pnop::nil; exit := None |} - | i::c => {| header := hd; body := i::c; exit := None |} - end. - *) - -(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) +(* gen_bblocks can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := match (extract_ctl ctl) with | None => @@ -1168,7 +1115,6 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil end -(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *) | Some (PExpand (Pbuiltin ef args res)) => match c with | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 89d41017..decc3e2e 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -1,3 +1,9 @@ +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + Require Import Coqlib. Require Intv. Require Import AST. @@ -31,19 +37,13 @@ Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. Proof. unfold ireg_of; intros. destruct (preg_of r); inv H; auto. -(* destruct b. all: try discriminate. - inv H1. auto. - *)Qed. +Qed. -(* FIXME - Replaced FR by IR for MPPA *) Lemma freg_of_eq: forall r r', freg_of r = OK r' -> preg_of r = IR r'. Proof. unfold freg_of; intros. destruct (preg_of r); inv H; auto. -(* destruct b. all: try discriminate. - inv H1. auto. - *)Qed. - +Qed. Lemma preg_of_injective: forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. @@ -277,24 +277,6 @@ Proof. exploit preg_of_injective; eauto. congruence. Qed. -(* Lemma agree_undef_regs2: - forall ms sp rl rs rs', - agree (Mach.undef_regs rl ms) sp rs -> - (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.undef_regs rl ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite <- agree_sp0. apply H0; auto. - rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. - intros. destruct (In_dec mreg_eq r rl). - rewrite Mach.undef_regs_same; auto. - rewrite H0; auto. - apply preg_of_data. - rewrite preg_notin_charact. intros; red; intros. elim n. - exploit preg_of_injective; eauto. congruence. -Qed. - *) - Lemma agree_set_undef_mreg: forall ms sp rs r v rl rs', agree ms sp rs -> @@ -607,15 +589,13 @@ Hypothesis transf_function_len: forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. -(* NB: the hypothesis in comment on [b] is not needed in the proof ! *) Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. destruct (transf_function f) as [tf|] eqn:TF. + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). -(* unfold return_address_offset. *) monadInv TR2. assert (TL3: is_tail x0 (fn_blocks tf)). { apply is_tail_trans with tc1; auto. @@ -632,7 +612,7 @@ Qed. End RETADDR_EXISTS. (** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - within the Asm code generated by translating Mach function [f], + within the Asmblock code generated by translating Machblock function [f], and [tc] is the tail of the generated code at the position corresponding to the code pointer [pc]. *) @@ -850,18 +830,6 @@ Proof. apply exec_straight_step with rs2 m2; auto. Qed. -(* Theorem exec_straight_bblock: - forall rs1 m1 rs2 m2 rs3 m3 b, - exec_straight (body b) rs1 m1 nil rs2 m2 -> - exec_control_rel (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel b rs1 m1 rs3 m3. -Proof. - intros. - econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto. - inv H0. auto. -Qed. *) - - Lemma exec_straight_two: forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> @@ -973,18 +941,6 @@ Proof. - reflexivity. Qed. -(* Lemma exec_straight_pc': - forall c rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - erewrite exec_basic_instr_pc; eauto. - - rewrite (IHc rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. *) - Lemma exec_straight_pc: forall c c' rs1 m1 rs2 m2, exec_straight c rs1 m1 c' rs2 m2 -> @@ -997,25 +953,6 @@ Proof. erewrite exec_basic_instr_pc; eauto. Qed. -(* Lemma exec_straight_through: - forall c i b lb rs1 m1 rs2 m2 rs2' m2', - bblock_basic_ctl c i = b -> - exec_straight c rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_control ge fn i rs2' m2' = Next rs2' m2' -> (* if the control does not jump *) - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. destruct i. - - constructor 1. - + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - + rewrite <- (exec_straight_pc c nil rs1 m1 rs2 m2'); auto. - - destruct c as [|i c]; try (inv H0; fail). - constructor 1. - + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto. -Qed. - *) - Lemma regset_same_assign (rs: regset) r: rs # r <- (rs r) = rs. Proof. @@ -1034,8 +971,6 @@ Proof. simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. Qed. - - (** The following lemmas show that straight-line executions (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) @@ -1086,7 +1021,6 @@ Qed. End STRAIGHTLINE. - (** * Properties of the Machblock call stack *) Section MATCH_STACK. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index bc549b4a..e1e2b0b0 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -15,6 +15,8 @@ (* *) (* *********************************************************************) +(** * Proof of correctness for individual instructions *) + Require Import Coqlib Errors Maps. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op Locations Machblock Conventions. @@ -86,31 +88,6 @@ Section CONSTRUCTORS. Variable ge: genv. Variable fn: function. -(* -(** 32-bit integer constants and arithmetic *) -(* -Lemma load_hilo32_correct: - forall rd hi lo k rs m, - exists rs', - exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m - /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold load_hilo32; intros. - predSpec Int.eq Int.eq_spec lo Int.zero. -- subst lo. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int.add_zero. Simpl. - intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. - intros; Simpl. -Qed. -*) - -*) - Lemma loadimm32_correct: forall rd n k rs m, exists rs', @@ -141,60 +118,6 @@ Proof. intros; Simpl. Qed. -(* -(* -Lemma opimm32_correct: - forall (op: ireg -> ireg0 -> ireg0 -> instruction) - (opi: ireg -> ireg0 -> int -> instruction) - (sem: val -> val -> val) m, - (forall d s1 s2 rs, - exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) -> - (forall d s n rs, - exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) -> - forall rd r1 n k rs, - r1 <> RTMP -> - exists rs', - exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m - /\ rs'#rd = sem rs##r1 (Vint n) - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. unfold opimm32. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. rewrite H0. simpl; eauto. auto. - split. Simpl. intros; Simpl. -- destruct (load_hilo32_correct RTMP hi lo (op rd r1 RTMP :: k) rs m) - as (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - rewrite H; eauto. auto. - split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. - intros; Simpl. -Qed. - -(** 64-bit integer constants and arithmetic *) - -Lemma load_hilo64_correct: - forall rd hi lo k rs m, - exists rs', - exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m - /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo) - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold load_hilo64; intros. - predSpec Int64.eq Int64.eq_spec lo Int64.zero. -- subst lo. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. rewrite Int64.add_zero. Simpl. - intros; Simpl. -- econstructor; split. - eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto. - split. Simpl. - intros; Simpl. -Qed. -*) -*) - Lemma opimm64_correct: forall (op: arith_name_rrr) (opi: arith_name_rri64) @@ -215,18 +138,6 @@ Proof. - subst imm. econstructor; split. apply exec_straight_one. rewrite H0. simpl; eauto. auto. split. Simpl. intros; Simpl. -(* -- destruct (load_hilo64_correct RTMP hi lo (op rd r1 RTMP :: k) rs m) - as (rs' & A & B & C). - econstructor; split. - eapply exec_straight_trans. eexact A. apply exec_straight_one. - rewrite H; eauto. auto. - split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence. - intros; Simpl. -- subst imm. econstructor; split. - eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto. - split. Simpl. intros; Simpl. -*) Qed. (** Add offset to pointer *) @@ -252,35 +163,6 @@ Proof. rewrite Ptrofs.of_int64_to_int64 by auto. auto. Qed. -(* -(* -Lemma addptrofs_correct_2: - forall rd r1 n k (rs: regset) m b ofs, - r1 <> RTMP -> rs#r1 = Vptr b of -s -> - exists rs', - exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m - /\ rs'#rd = Vptr b (Ptrofs.add ofs n) - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C). - exists rs'; intuition eauto. - rewrite H0 in B. inv B. auto. -Qed. - -(** Translation of conditional branches *) - -Remark branch_on_RTMP: - forall normal lbl (rs: regset) m b, - rs#RTMP = Val.of_bool (eqb normal b) -> - exec_instr ge fn (if normal then Pbnew RTMP X0 lbl else Pbeqw RTMP X0 lbl) rs m = - eval_branch fn lbl rs m (Some b). -Proof. - intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. -Qed. -*) -*) - Ltac ArgsInv := repeat (match goal with | [ H: Error _ = OK _ |- _ ] => discriminate @@ -1522,99 +1404,6 @@ Proof. exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. Qed. -(* -(* -+ (* cmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpf *) - destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)). - set (v := Val.cmpf c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_float_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. -+ (* cmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. - split; intros; Simpl. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := Val.notbool v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -+ (* notcmpfs *) - destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR. - rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)). - set (v := Val.cmpfs c0 (rs x) (rs x0)). - destruct normal; inv EQ2. -* econstructor; split. - eapply exec_straight_two. - eapply transl_cond_single_correct with (v := v); eauto. - simpl; reflexivity. - auto. auto. - split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto. -* econstructor; split. - apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. - split; intros; Simpl. -*) -*) - -(** Some arithmetic properties. *) - -(* Remark cast32unsigned_from_cast32signed: - forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)). -Proof. - intros. apply Int64.same_bits_eq; intros. - rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto. - rewrite Int.bits_signed by tauto. fold (Int.testbit i i0). - change Int.zwordsize with 32. - destruct (zlt i0 32). auto. apply Int.bits_above. auto. -Qed. - -Lemma cast32signed_correct: - forall (d s: ireg) (k: code) (rs: regset) (m: mem), - exists rs': regset, - exec_straight ge (cast32signed d s ::g k) rs m k rs' m - /\ Val.lessdef (Val.longofint (rs s)) (rs' d) - /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r). -Proof. - intros. unfold cast32signed. destruct (ireg_eq d s). -- econstructor; split. - + apply exec_straight_one. simpl. eauto with asmgen. - + split. - * rewrite e. Simpl. - * intros. destruct r; Simpl. -- econstructor; split. - + apply exec_straight_one. simpl. eauto with asmgen. - + split. - * Simpl. - * intros. destruct r; Simpl. -Qed. *) - (* Translation of arithmetic operations *) Ltac SimplEval H := @@ -1868,33 +1657,6 @@ Proof. + econstructor; econstructor; econstructor; econstructor; split. apply exec_straight_opt_refl. split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -(* -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_assoc. f_equal. f_equal. - rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ. - symmetry; auto with ptrofs. -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -(* 32 bits part, irrelevant for us -- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ. - destruct (make_immed32 (Ptrofs.to_int ofs)). -+ econstructor; econstructor; econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto. -+ econstructor; econstructor; econstructor; split. - constructor. eapply exec_straight_two. - simpl; eauto. simpl; eauto. auto. auto. - split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl. - rewrite Ptrofs.add_assoc. f_equal. f_equal. - rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ. - symmetry; auto with ptrofs. -*)*) Qed. @@ -2555,8 +2317,8 @@ Proof. { eapply A2. } { apply exec_straight_one. simpl. rewrite (C2 SP) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. - rewrite FREE'. eauto. (* auto. *) } } - * split. (* apply agree_nextinstr. *)apply agree_set_other; auto with asmgen. + rewrite FREE'. eauto. } } + * split. apply agree_set_other; auto with asmgen. apply agree_change_sp with (Vptr stk soff). apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. eapply parent_sp_def; eauto. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index e7e21a18..e0878c7d 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -10,7 +10,7 @@ (* *) (* *********************************************************************) -(** Correctness proof for RISC-V generation: main proof. *) +(** Correctness proof for Asmgen *) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. @@ -89,4 +89,4 @@ Module Asmgenproof0. Definition return_address_offset := return_address_offset. -End Asmgenproof0. \ No newline at end of file +End Asmgenproof0. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c6dd85f4..72584d2a 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -17,8 +17,6 @@ (** Abstract syntax and semantics for VLIW semantics of K1c assembly language. *) -(* FIXME: develop/fix the comments in this file *) - Require Import Coqlib. Require Import Maps. Require Import AST. @@ -45,8 +43,7 @@ Require Import Chunks. this view induces our sequential semantics of bundles defined in [Asmblock]. *) -(** General Purpose registers. -*) +(** General Purpose registers. *) Inductive gpreg: Type := | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg @@ -152,9 +149,6 @@ Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}. Proof. decide equality. Defined. -(** We model the following registers of the RISC-V architecture. *) - -(** basic register *) Inductive preg: Type := | IR: gpreg -> preg (**r integer general purpose registers *) | RA: preg @@ -173,7 +167,7 @@ End PregEq. Module Pregmap := EMap(PregEq). -(** Conventional names for stack pointer ([SP]) and return address ([RA]). *) +(** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *) Notation "'SP'" := GPR12 (only parsing) : asm. Notation "'FP'" := GPR17 (only parsing) : asm. @@ -188,9 +182,7 @@ Inductive btest: Type := | BTdgez (**r Double Greater Than or Equal to Zero *) | BTdlez (**r Double Less Than or Equal to Zero *) | BTdgtz (**r Double Greater Than Zero *) -(*| BTodd (**r Odd (LSB Set) *) - | BTeven (**r Even (LSB Clear) *) -*)| BTwnez (**r Word Not Equal to Zero *) + | BTwnez (**r Word Not Equal to Zero *) | BTweqz (**r Word Equal to Zero *) | BTwltz (**r Word Less Than Zero *) | BTwgez (**r Word Greater Than or Equal to Zero *) @@ -251,16 +243,7 @@ Definition offset : Type := ptrofs. Definition label := positive. -(* FIXME - rewrite the comment *) -(** A note on immediates: there are various constraints on immediate - operands to K1c instructions. We do not attempt to capture these - restrictions in the abstract syntax nor in the semantics. The - assembler will emit an error if immediate operands exceed the - representable range. Of course, our K1c generator (file - [Asmgen]) is careful to respect this range. *) - -(** Instructions to be expanded in control-flow -*) +(** Instructions to be expanded in control-flow *) Inductive ex_instruction : Type := (* Pseudo-instructions *) | Pbuiltin: external_function -> list (builtin_arg preg) -- cgit From 595db90221d4f45682ec5aaac0b485ff32af09e5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 17:47:58 +0200 Subject: begin implementing minf/maxf --- mppa_k1c/ExtFloats.v | 33 +++++++++++++++++++++++++++++++++ mppa_k1c/ExtValues.v | 25 +++++++++++++++++++++++++ mppa_k1c/NeedOp.v | 4 ++-- mppa_k1c/Op.v | 40 ++++++++++++++++++++++++++++++++-------- mppa_k1c/ValueAOp.v | 37 ++++++++++++++++++++++++++++++++++++- 5 files changed, 128 insertions(+), 11 deletions(-) create mode 100644 mppa_k1c/ExtFloats.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v new file mode 100644 index 00000000..efea278b --- /dev/null +++ b/mppa_k1c/ExtFloats.v @@ -0,0 +1,33 @@ +Require Import Floats. + +Module ExtFloat. +(** TODO check with the actual K1c *) + +Definition min (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. +End ExtFloat. + +Module ExtFloat32. +(** TODO check with the actual K1c *) + +Definition min (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. +End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3370fae3..a785375b 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,6 +1,7 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Require Import ExtFloats. Inductive shift1_4 : Type := | SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. @@ -671,3 +672,27 @@ Definition revsubx sh v1 v2 := Definition revsubxl sh v1 v2 := Val.subl v2 (Val.shll v1 (Vint sh)). + +Definition minf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.min f1 f2) + | _, _ => Vundef + end. + +Definition maxf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.max f1 f2) + | _, _ => Vundef + end. + +Definition minfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.min f1 f2) + | _, _ => Vundef + end. + +Definition maxfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2) + | _, _ => Vundef + end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 4748f38b..84e32d0f 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -121,9 +121,9 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omaddlimm n => op2 (default nv) | Omsubl => op3 (default nv) | Onegf | Oabsf => op1 (default nv) - | Oaddf | Osubf | Omulf | Odivf => op2 (default nv) + | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) - | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 35fbb596..4beef520 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -179,12 +179,16 @@ Inductive operation : Type := | Osubf (**r [rd = r1 - r2] *) | Omulf (**r [rd = r1 * r2] *) | Odivf (**r [rd = r1 / r2] *) + | Ominf + | Omaxf | Onegfs (**r [rd = - r1] *) | Oabsfs (**r [rd = abs(r1)] *) | Oaddfs (**r [rd = r1 + r2] *) | Osubfs (**r [rd = r1 - r2] *) | Omulfs (**r [rd = r1 * r2] *) | Odivfs (**r [rd = r1 / r2] *) + | Ominfs + | Omaxfs | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) @@ -426,12 +430,16 @@ Definition eval_operation | Osubf, v1::v2::nil => Some (Val.subf v1 v2) | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2) + | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2) | Onegfs, v1::nil => Some (Val.negfs v1) | Oabsfs, v1::nil => Some (Val.absfs v1) | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) + | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -630,16 +638,20 @@ Definition type_of_operation (op: operation) : list typ * typ := | Onegf => (Tfloat :: nil, Tfloat) | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) - | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) - | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + | Oaddf + | Osubf + | Omulf + | Odivf + | Ominf + | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) | Onegfs => (Tsingle :: nil, Tsingle) | Oabsfs => (Tsingle :: nil, Tsingle) - | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oaddfs + | Osubfs + | Omulfs + | Odivfs + | Ominfs + | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -906,6 +918,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* mulf, divf *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* minf, maxf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... (* negfs, absfs *) - destruct v0... - destruct v0... @@ -915,6 +930,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* mulfs, divfs *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* minfs, maxfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -1517,6 +1535,9 @@ Proof. (* mulf, divf *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* minf, maxf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. (* negfs, absfs *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1526,6 +1547,9 @@ Proof. (* mulfs, divfs *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* minfs, maxfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 439138da..0e9ce506 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -12,7 +12,12 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op ExtValues RTL ValueDomain. +Require Import Op ExtValues ExtFloats RTL ValueDomain. + +Definition minf := binop_float ExtFloat.min. +Definition maxf := binop_float ExtFloat.max. +Definition minfs := binop_single ExtFloat32.min. +Definition maxfs := binop_single ExtFloat32.max. (** Value analysis for RISC V operators *) @@ -235,12 +240,16 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Osubf, v1::v2::nil => subf v1 v2 | Omulf, v1::v2::nil => mulf v1 v2 | Odivf, v1::v2::nil => divf v1 v2 + | Ominf, v1::v2::nil => minf v1 v2 + | Omaxf, v1::v2::nil => maxf v1 v2 | Onegfs, v1::nil => negfs v1 | Oabsfs, v1::nil => absfs v1 | Oaddfs, v1::v2::nil => addfs v1 v2 | Osubfs, v1::v2::nil => subfs v1 v2 | Omulfs, v1::v2::nil => mulfs v1 v2 | Odivfs, v1::v2::nil => divfs v1 v2 + | Ominfs, v1::v2::nil => minfs v1 v2 + | Omaxfs, v1::v2::nil => maxfs v1 v2 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -278,6 +287,32 @@ Hypothesis GENV: genv_match bc ge. Variable sp: block. Hypothesis STACK: bc sp = BCstack. +Lemma minf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). +Proof. + apply (binop_float_sound bc ExtFloat.min); assumption. +Qed. + +Lemma maxf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y). +Proof. + apply (binop_float_sound bc ExtFloat.max); assumption. +Qed. + +Lemma minfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.min); assumption. +Qed. + +Lemma maxfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.max); assumption. +Qed. + +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound : va. + Theorem eval_static_condition_sound: forall cond vargs m aargs, list_forall2 (vmatch bc) vargs aargs -> -- cgit From 51094cecd5d24023e3de2487e66765f8c54b5fcc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 19:33:33 +0200 Subject: fmin/fmax/fminf/fmaxf non bien testés MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asm.v | 8 ++++++++ mppa_k1c/Asmblockdeps.v | 4 ++++ mppa_k1c/Asmblockgen.v | 12 ++++++++++++ mppa_k1c/Asmvliw.v | 9 +++++++++ mppa_k1c/Builtins1.v | 28 +++++++++++++++++++++++----- mppa_k1c/CBuiltins.ml | 10 ++++++++-- mppa_k1c/ExtFloats.v | 3 ++- mppa_k1c/PostpassSchedulingOracle.ml | 10 +++++++++- mppa_k1c/SelectOp.vp | 8 +++++++- mppa_k1c/SelectOpproof.v | 4 +++- mppa_k1c/TargetPrinter.ml | 8 ++++++++ 11 files changed, 93 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 620aa91e..35eebb11 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -227,6 +227,10 @@ Inductive instruction : Type := | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) (** Arith RRI32 *) | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) @@ -395,6 +399,10 @@ Definition basic_to_instruction (b: basic) := | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 (* RRI32 *) | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 9855afa2..cb219f00 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1423,6 +1423,10 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring := | Pfsbfw => "Pfsbfw" | Pfmuld => "Pfmuld" | Pfmulw => "Pfmulw" + | Pfmind => "Pfmind" + | Pfminw => "Pfminw" + | Pfmaxd => "Pfmaxd" + | Pfmaxw => "Pfmaxw" end. Definition string_of_name_rri32 (n: arith_name_rri32): pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index e5b9b35a..1f3f7539 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -775,6 +775,18 @@ Definition transl_op | Omulfs, a1 :: a2 :: nil => do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; OK (Pfmulw rd rs1 rs2 ::i k) + | Ominf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmind rd rs1 rs2 ::i k) + | Ominfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfminw rd rs1 rs2 ::i k) + | Omaxf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxd rd rs1 rs2 ::i k) + | Omaxfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxw rd rs1 rs2 ::i k) | Onegf, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegd rd rs ::i k) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index c5b7db45..a733b54c 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -470,6 +470,10 @@ Inductive arith_name_rrr : Type := | Pfsbfw (**r float sub word *) | Pfmuld (**r float multiply double *) | Pfmulw (**r float multiply word *) + | Pfmind (**r float min double *) + | Pfminw (**r float min word *) + | Pfmaxd (**r float max double *) + | Pfmaxw (**r float max word *) . Inductive arith_name_rri32 : Type := @@ -1072,6 +1076,11 @@ Definition arith_eval_rrr n v1 v2 := | Pfmuld => Val.mulf v1 v2 | Pfmulw => Val.mulfs v1 v2 + | Pfmind => ExtValues.minf v1 v2 + | Pfminw => ExtValues.minfs v1 v2 + | Pfmaxd => ExtValues.maxf v1 v2 + | Pfmaxw => ExtValues.maxfs v1 v2 + | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index f6e643d2..73d1bcf4 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -16,18 +16,36 @@ (** Platform-specific built-in functions *) Require Import String Coqlib. -Require Import AST Integers Floats Values. +Require Import AST Integers Floats Values ExtFloats. Require Import Builtins0. -Inductive platform_builtin : Type := . +Inductive platform_builtin : Type := +| BI_fmin +| BI_fmax +| BI_fminf +| BI_fmaxf. Local Open Scope string_scope. Definition platform_builtin_table : list (string * platform_builtin) := - nil. + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: ("__builtin_fminf", BI_fminf) + :: ("__builtin_fmaxf", BI_fmaxf) + :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := - match b with end. + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + | BI_fminf | BI_fmaxf => + mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := - match b with end. + match b with + | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min + | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max + | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min + | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max + end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 09a9ba97..43f3d98c 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -114,14 +114,20 @@ let builtins = { [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fnmsub", (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) "__builtin_fmax", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); "__builtin_fmin", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); -*)] + "__builtin_fmaxf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fminf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); +] } let va_list_type = TPtr(TVoid [], []) (* to check! *) diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index efea278b..090844f6 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -1,7 +1,8 @@ Require Import Floats. Module ExtFloat. -(** TODO check with the actual K1c *) +(** TODO check with the actual K1c; + this is what happens on x86 and may be inappropriate. *) Definition min (x : float) (y : float) : float := match Float.compare x y with diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 895f9f40..21cabfe9 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -31,6 +31,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fmind | Fminw | Fmaxd | Fmaxw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz | Fcompw | Fcompd @@ -119,6 +120,10 @@ let arith_rrr_real = function | Pfsbfw -> Fsbfw | Pfmuld -> Fmuld | Pfmulw -> Fmulw + | Pfmind -> Fmind + | Pfminw -> Fminw + | Pfmaxd -> Fmaxd + | Pfmaxw -> Fmaxw let arith_rri32_real = function | Pcompiw it -> Compw @@ -578,10 +583,12 @@ let rec_to_usage r = | Some E27U27L10 -> lsu_acc_y) | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop - | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -> alu_lite + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd + | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite | Fnarrowdw -> alu_full | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau + let real_inst_to_latency = function | Nop -> 0 (* Only goes through ID *) | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw @@ -590,6 +597,7 @@ let real_inst_to_latency = function | Nandd | Nord | Nxord | Ornd | Andnd | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd + | Fmind | Fmaxd | Fminw | Fmaxw -> 1 | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 688820b3..72597a2b 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -675,7 +675,13 @@ Definition divfs_base (e1: expr) (e2: expr) := End SELECT. Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := - None. + match b with + | BI_fmin => Some (Eop Ominf args) + | BI_fmax => Some (Eop Omaxf args) + | BI_fminf => Some (Eop Ominfs args) + | BI_fmaxf => Some (Eop Omaxfs args) + end. + (* Local Variables: *) (* mode: coq *) (* End: *) \ No newline at end of file diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index e009ed98..65685201 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1641,7 +1641,9 @@ Theorem eval_platform_builtin: platform_builtin_sem bf vl = Some v -> exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. Proof. - intros. discriminate. + destruct bf; intros until le; intro Heval; inversion Heval; subst a; clear Heval. + all: exists v; split; trivial; + try repeat (try econstructor; try eassumption). Qed. End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index dafad7fb..3ff016c2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -628,6 +628,14 @@ module Target (*: TARGET*) = fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfmulw (rd, rs1, rs2) -> fprintf oc " fmulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmind (rd, rs1, rs2) -> + fprintf oc " fmind %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfminw (rd, rs1, rs2) -> + fprintf oc " fminw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxd (rd, rs1, rs2) -> + fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxw (rd, rs1, rs2) -> + fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> -- cgit From c0984982ea5b8481bfc75c0ea4254eb5db07d875 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 29 Aug 2019 21:46:52 +0200 Subject: fabsf --- mppa_k1c/Builtins1.v | 7 ++++++- mppa_k1c/CBuiltins.ml | 3 +++ mppa_k1c/SelectOp.vp | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 73d1bcf4..5187ea7d 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -23,7 +23,8 @@ Inductive platform_builtin : Type := | BI_fmin | BI_fmax | BI_fminf -| BI_fmaxf. +| BI_fmaxf +| BI_fabsf. Local Open Scope string_scope. @@ -32,6 +33,7 @@ Definition platform_builtin_table : list (string * platform_builtin) := :: ("__builtin_fmax", BI_fmax) :: ("__builtin_fminf", BI_fminf) :: ("__builtin_fmaxf", BI_fmaxf) + :: ("__builtin_fabsf", BI_fabsf) :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := @@ -40,6 +42,8 @@ Definition platform_builtin_sig (b: platform_builtin) : signature := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default | BI_fminf | BI_fmaxf => mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + | BI_fabsf => + mksignature (Tsingle :: nil) (Some Tsingle) cc_default end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := @@ -48,4 +52,5 @@ Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_re | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max + | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 43f3d98c..c0022cb1 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -115,6 +115,9 @@ let builtins = { "__builtin_fnmsub", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) + "__builtin_fabsf", + (TFloat(FFloat, []), + [TFloat(FFloat, [])], false); "__builtin_fmax", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false); diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 72597a2b..c8139ecb 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -680,6 +680,7 @@ Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr | BI_fmax => Some (Eop Omaxf args) | BI_fminf => Some (Eop Ominfs args) | BI_fmaxf => Some (Eop Omaxfs args) + | BI_fabsf => Some (Eop Oabsfs args) end. (* Local Variables: *) -- cgit From cfc681ae18c59f4a19143a7245be23eb6a4045a0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 10:10:06 +0200 Subject: add finvw ; not yet generated --- mppa_k1c/Asm.v | 4 +++- mppa_k1c/Asmblockdeps.v | 1 + mppa_k1c/Asmblockgen.v | 3 +++ mppa_k1c/Asmvliw.v | 2 ++ mppa_k1c/ExtFloats.v | 6 +++++- mppa_k1c/ExtValues.v | 6 ++++++ mppa_k1c/NeedOp.v | 1 + mppa_k1c/Op.v | 7 +++++++ mppa_k1c/PostpassSchedulingOracle.ml | 7 ++++--- mppa_k1c/TargetPrinter.ml | 2 ++ mppa_k1c/ValueAOp.v | 22 +++++++++++++++++++++- 11 files changed, 55 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 35eebb11..b7818aaf 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -231,7 +231,8 @@ Inductive instruction : Type := | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + (** Arith RRI32 *) | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) @@ -327,6 +328,7 @@ Definition basic_to_instruction (b: basic) := | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index cb219f00..61caeaf1 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1343,6 +1343,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring := | Pfabsw => "Pfabsw" | Pfnegd => "Pfnegd" | Pfnegw => "Pfnegw" + | Pfinvw => "Pfinvw" | Pfnarrowdw => "Pfnarrowdw" | Pfwidenlwd => "Pfwidenlwd" | Pfloatwrnsz => "Pfloatwrnsz" diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 1f3f7539..c2a36ff7 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -793,6 +793,9 @@ Definition transl_op | Onegfs, a1 :: nil => do rd <- freg_of res; do rs <- freg_of a1; OK (Pfnegw rd rs ::i k) + | Oinvfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfinvw rd rs ::i k) | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index a733b54c..cb9ce7ae 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -392,6 +392,7 @@ Inductive arith_name_rr : Type := | Pfabsw (**r float absolute word *) | Pfnegd (**r float negate double *) | Pfnegw (**r float negate word *) + | Pfinvw (**r float invert word *) | Pfnarrowdw (**r float narrow 64 -> 32 bits *) | Pfwidenlwd (**r Floating Point widen from 32 bits to 64 bits *) | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) @@ -996,6 +997,7 @@ Definition arith_eval_rr n v := | Pfnegw => Val.negfs v | Pfabsd => Val.absf v | Pfabsw => Val.absfs v + | Pfinvw => ExtValues.invfs v | Pfnarrowdw => Val.singleoffloat v | Pfwidenlwd => Val.floatofsingle v | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index 090844f6..b2fc6581 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -1,4 +1,4 @@ -Require Import Floats. +Require Import Floats Integers ZArith. Module ExtFloat. (** TODO check with the actual K1c; @@ -31,4 +31,8 @@ Definition max (x : float32) (y : float32) : float32 := | Some Eq | Some Gt => x | Some Lt | None => y end. + +Definition inv (x : float32) : float32 := + Float32.div (Float32.of_int (Int.repr (1%Z))) x. + End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index a785375b..9cec5669 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -696,3 +696,9 @@ Definition maxfs v1 v2 := | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2) | _, _ => Vundef end. + +Definition invfs v1 := + match v1 with + | (Vsingle f1) => Vsingle (ExtFloat32.inv f1) + | _ => Vundef + end. diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 84e32d0f..856f5b54 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -124,6 +124,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) + | Oinvfs => op1 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 4beef520..de372157 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -189,6 +189,7 @@ Inductive operation : Type := | Odivfs (**r [rd = r1 / r2] *) | Ominfs | Omaxfs + | Oinvfs | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) @@ -440,6 +441,7 @@ Definition eval_operation | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) + | Oinvfs, v1::nil => Some (ExtValues.invfs v1) | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -652,6 +654,7 @@ Definition type_of_operation (op: operation) : list typ * typ := | Odivfs | Ominfs | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oinvfs => (Tsingle :: nil, Tsingle) | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -933,6 +936,8 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* minfs, maxfs *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* invfs *) + - destruct v0... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -1550,6 +1555,8 @@ Proof. (* minfs, maxfs *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* invfs *) + - inv H4; simpl; auto. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 21cabfe9..e2baa2c0 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -31,7 +31,7 @@ type real_instruction = (* FPU *) | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fmind | Fminw | Fmaxd | Fmaxw + | Fmind | Fminw | Fmaxd | Fmaxw | Finvw | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz | Fcompw | Fcompd @@ -62,6 +62,7 @@ let arith_rr_real = function | Pfabsd -> Fabsd | Pfnegw -> Fnegw | Pfnegd -> Fnegd + | Pfinvw -> Finvw | Pfnarrowdw -> Fnarrowdw | Pfwidenlwd -> Fwidenlwd | Pfloatwrnsz -> Floatwz @@ -586,7 +587,7 @@ let rec_to_usage r = | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite | Fnarrowdw -> alu_full - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw -> mau let real_inst_to_latency = function @@ -607,7 +608,7 @@ let real_inst_to_latency = function | Set -> 4 (* According to the manual should be 3, but I measured 4 *) | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 4 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw -> 4 let rec_to_info r : inst_info = let usage = rec_to_usage r diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3ff016c2..3d3b56a2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -636,6 +636,8 @@ module Target (*: TARGET*) = fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfmaxw (rd, rs1, rs2) -> fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfinvw (rd, rs1) -> + fprintf oc " finvw %a = %a\n" ireg rd ireg rs1 (* Arith RRI32 instructions *) | Pcompiw (it, rd, rs, imm) -> diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 0e9ce506..edbdc0b2 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -19,6 +19,15 @@ Definition maxf := binop_float ExtFloat.max. Definition minfs := binop_single ExtFloat32.min. Definition maxfs := binop_single ExtFloat32.max. +Definition invfs (y : aval) := + match y with + | FS f => FS (ExtFloat32.inv f) + | _ => ntop1 y + end. + +Definition binop_float (sem: float -> float -> float) (x y: aval) := + match x, y with F n, F m => F (sem n m) | _, _ => ntop2 x y end. + (** Value analysis for RISC V operators *) Definition eval_static_condition (cond: condition) (vl: list aval): abool := @@ -250,6 +259,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Odivfs, v1::v2::nil => divfs v1 v2 | Ominfs, v1::v2::nil => minfs v1 v2 | Omaxfs, v1::v2::nil => maxfs v1 v2 + | Oinvfs, v1::nil => invfs v1 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -311,7 +321,17 @@ Proof. apply (binop_single_sound bc ExtFloat32.max); assumption. Qed. -Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound : va. +Lemma invfs_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x). +Proof. + intros v x; + intro MATCH; + inversion MATCH; + simpl; + constructor. +Qed. + +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound : va. Theorem eval_static_condition_sound: forall cond vargs m aargs, -- cgit From 344fd96e0690ff4809623198baeee823132f7219 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 12:30:16 +0200 Subject: use finvw --- mppa_k1c/ExtFloats.v | 3 ++- mppa_k1c/SelectOp.vp | 15 +++++++++++++-- mppa_k1c/SelectOpproof.v | 31 ++++++++++++++++++++++++++++++- 3 files changed, 45 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index b2fc6581..d9b9d3a6 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -32,7 +32,8 @@ Definition max (x : float32) (y : float32) : float32 := | Some Lt | None => y end. +Definition one := Float32.of_int (Int.repr (1%Z)). Definition inv (x : float32) : float32 := - Float32.div (Float32.of_int (Int.repr (1%Z))) x. + Float32.div one x. End ExtFloat32. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index c8139ecb..6539184c 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -51,7 +51,7 @@ Require Import Floats. Require Import Op. Require Import CminorSel. Require Import OpHelpers. -Require Import ExtValues. +Require Import ExtValues ExtFloats. Require Import DecBoolOps. Require Import Chunks. Require Import Builtins. @@ -669,9 +669,20 @@ Definition divf_base (e1: expr) (e2: expr) := (* Eop Odivf (e1 ::: e2 ::: Enil). *) Eexternal f64_div sig_ff_f (e1 ::: e2 ::: Enil). -Definition divfs_base (e1: expr) (e2: expr) := +Definition divfs_base1 (e2 : expr) := + Eop Oinvfs (e2 ::: Enil). +Definition divfs_baseX (e1 : expr) (e2 : expr) := (* Eop Odivf (e1 ::: e2 ::: Enil). *) Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). + +Nondetfunction divfs_base (e1: expr) := + match e1 with + | Eop (Osingleconst f) Enil => + (if Float32.eq_dec f ExtFloat32.one + then divfs_base1 + else divfs_baseX e1) + | _ => divfs_baseX e1 + end. End SELECT. Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 65685201..7805a1be 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1622,6 +1622,29 @@ Proof. econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. Qed. + +Lemma eval_divfs_base1: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divfs_base1 b) v /\ Val.lessdef (ExtValues.invfs y) v. +Proof. + intros; unfold divfs_base1. + econstructor; split. + repeat (try econstructor; try eassumption). + trivial. +Qed. + +Lemma eval_divfs_baseX: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divfs_baseX a b) v /\ Val.lessdef (Val.divfs x y) v. +Proof. + intros; unfold divfs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + Theorem eval_divfs_base: forall le a b x y, eval_expr ge sp e m le a x -> @@ -1629,7 +1652,13 @@ Theorem eval_divfs_base: exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v. Proof. intros; unfold divfs_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. + destruct (divfs_base_match _). + - destruct (Float32.eq_dec _ _). + + exists (Val.divfs x y). + split; trivial. repeat (try econstructor; try eassumption). + simpl. InvEval. reflexivity. + + apply eval_divfs_baseX; assumption. + - apply eval_divfs_baseX; assumption. Qed. (** Platform-specific known builtins *) -- cgit From 436bf1192e129427f6fcc99d2e6b75db08e80cf8 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 15:08:07 +0200 Subject: (#157) Removed AFADDD and AFADDW from the builtins --- mppa_k1c/Asm.v | 4 ++-- mppa_k1c/Asmexpand.ml | 4 ++-- mppa_k1c/CBuiltins.ml | 4 ++-- mppa_k1c/TargetPrinter.ml | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 1964e5f8..a0c5e71c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -99,8 +99,8 @@ Inductive instruction : Type := | Piinvals (addr: ireg) | Pitouchl (addr: ireg) | Pdzerol (addr: ireg) - | Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) | Palclrd (dst: ireg) (addr: ireg) | Palclrw (dst: ireg) (addr: ireg) | Pclzll (rd rs: ireg) diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 65dee6c7..20d27951 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -465,14 +465,14 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Pitouchl addr) | "__builtin_k1_dzerol", [BA(IR addr)], _ -> emit (Pdzerol addr) - | "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> +(*| "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res then (emit (Pmv(res, incr_res)); emit Psemi)); emit (Pafaddd(addr, res)) | "__builtin_k1_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> (if res <> incr_res then (emit (Pmv(res, incr_res)); emit Psemi)); - emit (Pafaddw(addr, res)) + emit (Pafaddw(addr, res)) *) (* see #157 *) | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> emit (Palclrd(res, addr)) | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 2f80c90f..a02da077 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -43,8 +43,8 @@ let builtins = { (* LSU Instructions *) (* acswapd and acswapw done using headers and assembly *) - "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); - "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); +(* "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); *) (* see #157 *) "__builtin_k1_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 674695d9..2621a43b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -399,10 +399,10 @@ module Target (*: TARGET*) = fprintf oc " itouchl 0[%a]\n" ireg addr | Pdzerol addr -> fprintf oc " dzerol 0[%a]\n" ireg addr - | Pafaddd(addr, incr_res) -> +(* | Pafaddd(addr, incr_res) -> fprintf oc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res | Pafaddw(addr, incr_res) -> - fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res + fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) | Palclrd(res, addr) -> fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr | Palclrw(res, addr) -> -- cgit From 21622a06394e68170a9901f316addcd3fd1841de Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 15:38:14 +0200 Subject: Added more tests --- mppa_k1c/TargetPrinter.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 2621a43b..c9822e13 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -400,9 +400,9 @@ module Target (*: TARGET*) = | Pdzerol addr -> fprintf oc " dzerol 0[%a]\n" ireg addr (* | Pafaddd(addr, incr_res) -> - fprintf oc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res + fprintfoc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res | Pafaddw(addr, incr_res) -> - fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) + fprintfoc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) | Palclrd(res, addr) -> fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr | Palclrw(res, addr) -> -- cgit From 1522f289301f37da0324570297c65256d8a32316 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 16:46:11 +0200 Subject: début du fma MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/ExtValues.v | 20 ++++++++++++- mppa_k1c/NeedOp.v | 55 ++++++++++++++++++++++++++++++++-- mppa_k1c/Op.v | 26 ++++++++++++++++ mppa_k1c/ValueAOp.v | 85 +++++++++++++++++++++++++++++++++++++++++++++++++--- 4 files changed, 179 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 9cec5669..3e4b70b5 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,7 +1,7 @@ Require Import Coqlib. Require Import Integers. Require Import Values. -Require Import ExtFloats. +Require Import Floats ExtFloats. Inductive shift1_4 : Type := | SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. @@ -702,3 +702,21 @@ Definition invfs v1 := | (Vsingle f1) => Vsingle (ExtFloat32.inv f1) | _ => Vundef end. + +Definition triple_op_float f v1 v2 v3 := + match v1, v2, v3 with + | (Vfloat f1), (Vfloat f2), (Vfloat f3) => Vfloat (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition triple_op_single f v1 v2 v3 := + match v1, v2, v3 with + | (Vsingle f1), (Vsingle f2), (Vsingle f3) => Vsingle (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition fmaddf := triple_op_float Float.fma. +Definition fmaddfs := triple_op_single Float32.fma. + +Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma f1 (Float.neg f2) f3). +Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma f1 (Float32.neg f2) f3). diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 856f5b54..d2d4d5f5 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -122,9 +122,11 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval := | Omsubl => op3 (default nv) | Onegf | Oabsf => op1 (default nv) | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) + | Ofmaddf | Ofmsubf => op3 (default nv) | Onegfs | Oabsfs => op1 (default nv) | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) | Oinvfs => op1 (default nv) + | Ofmaddfs | Ofmsubfs => op3 (default nv) | Ofloatofsingle | Osingleoffloat => op1 (default nv) | Ointoffloat | Ointuoffloat => op1 (default nv) | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) @@ -286,7 +288,53 @@ Remark default_idem: forall nv, default (default nv) = default nv. Proof. destruct nv; simpl; trivial. Qed. - + +Lemma vagree_triple_op_float : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_float f a b c) + (ExtValues.triple_op_float f x y z) nv). +Proof. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. +Qed. + +Lemma vagree_triple_op_single : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_single f a b c) + (ExtValues.triple_op_single f x y z) nv). +Proof. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. +Qed. + +Hint Resolve vagree_triple_op_float vagree_triple_op_single : na. + Lemma needs_of_operation_sound: forall op args v nv args', eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> @@ -345,7 +393,10 @@ Proof. apply mull_sound; trivial. rewrite default_idem; trivial. rewrite default_idem; trivial. - (* select *) +- apply vagree_triple_op_float; assumption. +- apply vagree_triple_op_float; assumption. +- apply vagree_triple_op_single; assumption. +- apply vagree_triple_op_single; assumption. - destruct (eval_condition0 _ _ _) as [b|] eqn:EC. erewrite needs_of_condition0_sound by eauto. apply select_sound; auto. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index de372157..b3258259 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -181,6 +181,8 @@ Inductive operation : Type := | Odivf (**r [rd = r1 / r2] *) | Ominf | Omaxf + | Ofmaddf + | Ofmsubf | Onegfs (**r [rd = - r1] *) | Oabsfs (**r [rd = abs(r1)] *) | Oaddfs (**r [rd = r1 + r2] *) @@ -190,6 +192,8 @@ Inductive operation : Type := | Ominfs | Omaxfs | Oinvfs + | Ofmaddfs + | Ofmsubfs | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) (*c Conversions between int and float: *) @@ -433,6 +437,9 @@ Definition eval_operation | Odivf, v1::v2::nil => Some (Val.divf v1 v2) | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2) | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2) + | Ofmaddf, v1::v2::v3::nil => Some (ExtValues.fmaddf v1 v2 v3) + | Ofmsubf, v1::v2::v3::nil => Some (ExtValues.fmsubf v1 v2 v3) + | Onegfs, v1::nil => Some (Val.negfs v1) | Oabsfs, v1::nil => Some (Val.absfs v1) | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) @@ -442,6 +449,9 @@ Definition eval_operation | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) | Oinvfs, v1::nil => Some (ExtValues.invfs v1) + | Ofmaddfs, v1::v2::v3::nil => Some (ExtValues.fmaddfs v1 v2 v3) + | Ofmsubfs, v1::v2::v3::nil => Some (ExtValues.fmsubfs v1 v2 v3) + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) | Ointoffloat, v1::nil => Val.intoffloat v1 @@ -646,6 +656,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Odivf | Ominf | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) + | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + | Onegfs => (Tsingle :: nil, Tsingle) | Oabsfs => (Tsingle :: nil, Tsingle) | Oaddfs @@ -655,6 +667,8 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ominfs | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) | Oinvfs => (Tsingle :: nil, Tsingle) + | Ofmaddfs | Ofmsubfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle) + | Osingleoffloat => (Tfloat :: nil, Tsingle) | Ofloatofsingle => (Tsingle :: nil, Tfloat) | Ointoffloat => (Tfloat :: nil, Tint) @@ -924,6 +938,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). (* minf, maxf *) - destruct v0; destruct v1... - destruct v0; destruct v1... + (* fmaddf, fmsubf *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... (* negfs, absfs *) - destruct v0... - destruct v0... @@ -938,6 +955,9 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1... (* invfs *) - destruct v0... + (* fmaddfs, fmsubfs *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... (* singleoffloat, floatofsingle *) - destruct v0... - destruct v0... @@ -1543,6 +1563,9 @@ Proof. (* minf, maxf *) - inv H4; inv H2; simpl; auto. - inv H4; inv H2; simpl; auto. + (* fmaddf, fmsubf *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. (* negfs, absfs *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1557,6 +1580,9 @@ Proof. - inv H4; inv H2; simpl; auto. (* invfs *) - inv H4; simpl; auto. + (* fmaddfs, fmsubfs *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. (* singleoffloat, floatofsingle *) - inv H4; simpl; auto. - inv H4; simpl; auto. diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index edbdc0b2..4c5fcf71 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -19,14 +19,30 @@ Definition maxf := binop_float ExtFloat.max. Definition minfs := binop_single ExtFloat32.min. Definition maxfs := binop_single ExtFloat32.max. +Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))). + +Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) := + match x, y, z with + | F a, F b, F c => F (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) := + match x, y, z with + | FS a, FS b, FS c => FS (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition fmaddf := triple_op_float Float.fma. +Definition fmsubf := triple_op_float (fun x y z => Float.fma x (Float.neg y) z). +Definition fmaddfs := triple_op_single Float32.fma. +Definition fmsubfs := triple_op_single (fun x y z => Float32.fma x (Float32.neg y) z). + Definition invfs (y : aval) := match y with | FS f => FS (ExtFloat32.inv f) | _ => ntop1 y end. - -Definition binop_float (sem: float -> float -> float) (x y: aval) := - match x, y with F n, F m => F (sem n m) | _, _ => ntop2 x y end. (** Value analysis for RISC V operators *) @@ -251,6 +267,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Odivf, v1::v2::nil => divf v1 v2 | Ominf, v1::v2::nil => minf v1 v2 | Omaxf, v1::v2::nil => maxf v1 v2 + | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3 + | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3 | Onegfs, v1::nil => negfs v1 | Oabsfs, v1::nil => absfs v1 | Oaddfs, v1::v2::nil => addfs v1 v2 @@ -260,6 +278,8 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ominfs, v1::v2::nil => minfs v1 v2 | Omaxfs, v1::v2::nil => maxfs v1 v2 | Oinvfs, v1::nil => invfs v1 + | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3 + | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 | Ointoffloat, v1::nil => intoffloat v1 @@ -331,7 +351,64 @@ Proof. constructor. Qed. -Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound : va. +Lemma triple_op_float_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_float f a b c) + (triple_op_float f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma triple_op_single_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_single f a b c) + (triple_op_single f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma fmaddf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z). +Proof. + intros. unfold ExtValues.fmaddf, fmaddf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmaddfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z). +Proof. + intros. unfold ExtValues.fmaddfs, fmaddfs. + apply triple_op_single_sound; assumption. +Qed. + +Lemma fmsubf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z). +Proof. + intros. unfold ExtValues.fmsubf, fmsubf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmsubfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z). +Proof. + intros. unfold ExtValues.fmsubfs, fmsubfs. + apply triple_op_single_sound; assumption. +Qed. +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va. Theorem eval_static_condition_sound: forall cond vargs m aargs, -- cgit From ccd2fa5638e50b5fd8308b4b0c26531f911ff087 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 30 Aug 2019 17:08:07 +0200 Subject: Rajout de clzd dans les tests --- mppa_k1c/CBuiltins.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index a02da077..5fb69f62 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -63,7 +63,6 @@ let builtins = { "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* ALU Instructions *) - "__builtin_clzll", (TInt(IULongLong, []), [TInt(IULongLong, [])], false); (* "__builtin_k1_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_bwlu", (TInt(IUInt, []), @@ -74,8 +73,8 @@ let builtins = { (* "__builtin_k1_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) (* "__builtin_k1_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_k1_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - "__builtin_k1_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_k1_clzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); (* "__builtin_k1_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) (* "__builtin_k1_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) (* "__builtin_k1_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) -- cgit From caac487ae23a9785602cf235f5b4a2b6749f2c18 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 19:10:42 +0200 Subject: fma --- mppa_k1c/Asm.v | 8 ++++++ mppa_k1c/Asmblockdeps.v | 4 +++ mppa_k1c/Asmblockgen.v | 25 +++++++++++++++++ mppa_k1c/Asmvliw.v | 8 ++++++ mppa_k1c/Builtins1.v | 12 +++++++- mppa_k1c/CBuiltins.ml | 6 ++++ mppa_k1c/ExtValues.v | 8 +++--- mppa_k1c/Machregs.v | 2 ++ mppa_k1c/PostpassSchedulingOracle.ml | 11 ++++++-- mppa_k1c/SelectOp.vp | 16 ++++++++++- mppa_k1c/SelectOpproof.v | 53 ++++++++++++++++++++++++++++++++++-- mppa_k1c/TargetPrinter.ml | 8 ++++++ mppa_k1c/ValueAOp.v | 8 +++--- 13 files changed, 154 insertions(+), 15 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index b7818aaf..ce376af9 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -200,6 +200,10 @@ Inductive instruction : Type := | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) | Paddl (rd rs1 rs2: ireg) (**r add long *) | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) @@ -452,6 +456,10 @@ Definition basic_to_instruction (b: basic) := | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 61caeaf1..6743ae4c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1483,6 +1483,10 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring := | Pmsubl => "Pmsubl" | Pcmove _ => "Pcmove" | Pcmoveu _ => "Pcmoveu" + | Pfmaddfw => "Pfmaddfw" + | Pfmaddfl => "Pfmaddfl" + | Pfmsubfw => "Pfmsubfw" + | Pfmsubfl => "Pfmsubfl" end. Definition string_of_name_arr (n: arith_name_arr): pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index c2a36ff7..c717af95 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -797,6 +797,31 @@ Definition transl_op do rd <- freg_of res; do rs <- freg_of a1; OK (Pfinvw rd rs ::i k) + | Ofmaddf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfl rs1 rs2 rs3 ::i k) + | Ofmaddfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfw rs1 rs2 rs3 ::i k) + | Ofmsubf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfl rs1 rs2 rs3 ::i k) + | Ofmsubfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfw rs1 rs2 rs3 ::i k) + | Osingleofint, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfloatwrnsz rd rs ::i k) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index cb9ce7ae..b0f8501d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -528,6 +528,10 @@ Inductive arith_name_arrr : Type := | Pmsubl (**r multiply subtract long *) | Pcmove (bt: btest) (**r conditional move *) | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) + | Pfmaddfw (**r float fused multiply add word *) + | Pfmaddfl (**r float fused multiply add long *) + | Pfmsubfw (**r float fused multiply subtract word *) + | Pfmsubfl (**r float fused multiply subtract long *) . Inductive arith_name_arri32 : Type := @@ -1177,6 +1181,10 @@ Definition arith_eval_arrr n v1 v2 v3 := | Pmsubl => Val.subl v1 (Val.mull v2 v3) | Pcmove bt => cmove bt v1 v2 v3 | Pcmoveu bt => cmoveu bt v1 v2 v3 + | Pfmaddfw => ExtValues.fmaddfs v1 v2 v3 + | Pfmaddfl => ExtValues.fmaddf v1 v2 v3 + | Pfmsubfw => ExtValues.fmsubfs v1 v2 v3 + | Pfmsubfl => ExtValues.fmsubf v1 v2 v3 end. Definition arith_eval_arr n v1 v2 := diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 5187ea7d..6186961f 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -24,7 +24,9 @@ Inductive platform_builtin : Type := | BI_fmax | BI_fminf | BI_fmaxf -| BI_fabsf. +| BI_fabsf +| BI_fma +| BI_fmaf. Local Open Scope string_scope. @@ -34,6 +36,8 @@ Definition platform_builtin_table : list (string * platform_builtin) := :: ("__builtin_fminf", BI_fminf) :: ("__builtin_fmaxf", BI_fmaxf) :: ("__builtin_fabsf", BI_fabsf) + :: ("__builtin_fma", BI_fma) + :: ("__builtin_fmaf", BI_fmaf) :: nil. Definition platform_builtin_sig (b: platform_builtin) : signature := @@ -44,6 +48,10 @@ Definition platform_builtin_sig (b: platform_builtin) : signature := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default | BI_fabsf => mksignature (Tsingle :: nil) (Some Tsingle) cc_default + | BI_fma => + mksignature (Tfloat :: Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + | BI_fmaf => + mksignature (Tsingle :: Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default end. Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := @@ -53,4 +61,6 @@ Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_re | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs + | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma + | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index c0022cb1..3ae6baa7 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -130,6 +130,12 @@ let builtins = { "__builtin_fminf", (TFloat(FFloat, []), [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fma", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmaf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, []); TFloat(FFloat, [])], false); ] } diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3e4b70b5..a8e24c86 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -715,8 +715,8 @@ Definition triple_op_single f v1 v2 v3 := | _, _, _ => Vundef end. -Definition fmaddf := triple_op_float Float.fma. -Definition fmaddfs := triple_op_single Float32.fma. +Definition fmaddf := triple_op_float (fun f1 f2 f3 => Float.fma f2 f3 f1). +Definition fmaddfs := triple_op_single (fun f1 f2 f3 => Float32.fma f2 f3 f1). -Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma f1 (Float.neg f2) f3). -Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma f1 (Float32.neg f2) f3). +Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma (Float.neg f2) f3 f1). +Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma (Float32.neg f2) f3 f1). diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 5a7d42b4..8098b5d1 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -213,6 +213,8 @@ Global Opaque Definition two_address_op (op: operation) : bool := match op with + | Ofmaddf | Ofmaddfs + | Ofmsubf | Ofmsubfs | Omadd | Omaddimm _ | Omaddl | Omaddlimm _ | Omsub | Omsubl diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index e2baa2c0..628ae609 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -32,6 +32,7 @@ type real_instruction = | Fabsd | Fabsw | Fnegw | Fnegd | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Fmind | Fminw | Fmaxd | Fmaxw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz | Fcompw | Fcompd @@ -173,6 +174,10 @@ let arith_arr_real = function | Pinsfl (_, _) -> Insf let arith_arrr_real = function + | Pfmaddfw -> Ffmaw + | Pfmaddfl -> Ffmad + | Pfmsubfw -> Ffmsw + | Pfmsubfl -> Ffmsd | Pmaddw -> Maddw | Pmaddl -> Maddd | Pmsubw -> Msbfw @@ -587,7 +592,8 @@ let rec_to_usage r = | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite | Fnarrowdw -> alu_full - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw -> mau + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau let real_inst_to_latency = function @@ -608,7 +614,8 @@ let real_inst_to_latency = function | Set -> 4 (* According to the manual should be 3, but I measured 4 *) | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw -> 4 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4 let rec_to_info r : inst_info = let usage = rec_to_usage r diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 6539184c..71078046 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -683,7 +683,18 @@ Nondetfunction divfs_base (e1: expr) := else divfs_baseX e1) | _ => divfs_baseX e1 end. -End SELECT. + +Nondetfunction gen_fma args := + match args with + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Nondetfunction gen_fmaf args := + match args with + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil)) + | _ => None + end. Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := match b with @@ -692,7 +703,10 @@ Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr | BI_fminf => Some (Eop Ominfs args) | BI_fmaxf => Some (Eop Omaxfs args) | BI_fabsf => Some (Eop Oabsfs args) + | BI_fma => gen_fma args + | BI_fmaf => gen_fmaf args end. +End SELECT. (* Local Variables: *) (* mode: coq *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 7805a1be..08bcff12 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1663,6 +1663,50 @@ Qed. (** Platform-specific known builtins *) +Lemma eval_fma: + forall al a vl v le, + gen_fma al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fma vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fma. + intros until le. + intro Heval. + destruct (gen_fma_match _) in *; try discriminate. + inversion Heval; subst a; clear Heval. + intro; InvEval. + intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + +Lemma eval_fmaf: + forall al a vl v le, + gen_fmaf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fmaf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fmaf. + intros until le. + intro Heval. + destruct (gen_fmaf_match _) in *; try discriminate. + inversion Heval; subst a; clear Heval. + intro; InvEval. + intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + Theorem eval_platform_builtin: forall bf al a vl v le, platform_builtin bf al = Some a -> @@ -1670,9 +1714,12 @@ Theorem eval_platform_builtin: platform_builtin_sem bf vl = Some v -> exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. Proof. - destruct bf; intros until le; intro Heval; inversion Heval; subst a; clear Heval. - all: exists v; split; trivial; - try repeat (try econstructor; try eassumption). + destruct bf; intros until le; intro Heval. + all: try (inversion Heval; subst a; clear Heval; + exists v; split; trivial; + repeat (try econstructor; try eassumption)). + - apply eval_fma; assumption. + - apply eval_fmaf; assumption. Qed. End CMCONSTR. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 3d3b56a2..e626d2b4 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -574,6 +574,10 @@ module Target (*: TARGET*) = fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmsubw (rd, rs1, rs2) -> fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfw (rd, rs1, rs2) -> + fprintf oc " ffmaw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfw (rd, rs1, rs2) -> + fprintf oc " ffmsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Paddl (rd, rs1, rs2) -> fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 @@ -615,6 +619,10 @@ module Target (*: TARGET*) = fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pmsubl (rd, rs1, rs2) -> fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfl (rd, rs1, rs2) -> + fprintf oc " ffmad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfl (rd, rs1, rs2) -> + fprintf oc " ffmsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 | Pfaddd (rd, rs1, rs2) -> fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 4c5fcf71..2c9bdf3e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -33,10 +33,10 @@ Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y | _, _, _ => ntop3 x y z end. -Definition fmaddf := triple_op_float Float.fma. -Definition fmsubf := triple_op_float (fun x y z => Float.fma x (Float.neg y) z). -Definition fmaddfs := triple_op_single Float32.fma. -Definition fmsubfs := triple_op_single (fun x y z => Float32.fma x (Float32.neg y) z). +Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x). +Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x). +Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x). +Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x). Definition invfs (y : aval) := match y with -- cgit From 9a19f2fdf735785947cc469d2ceef83cbe4f1679 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 30 Aug 2019 19:23:24 +0200 Subject: fma with first negated operand --- mppa_k1c/SelectOp.vp | 2 ++ mppa_k1c/SelectOpproof.v | 20 ++++++++++++++------ 2 files changed, 16 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index 71078046..ec3985c5 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -686,12 +686,14 @@ Nondetfunction divfs_base (e1: expr) := Nondetfunction gen_fma args := match args with + | (Eop Onegf (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubf (e3:::e1:::e2:::Enil)) | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) | _ => None end. Nondetfunction gen_fmaf args := match args with + | (Eop Onegfs (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubfs (e3:::e1:::e2:::Enil)) | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil)) | _ => None end. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 08bcff12..583fb545 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1674,9 +1674,13 @@ Proof. intros until le. intro Heval. destruct (gen_fma_match _) in *; try discriminate. - inversion Heval; subst a; clear Heval. - intro; InvEval. - intro Heval. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. simpl in Heval. inv Heval. TrivialExists. @@ -1696,9 +1700,13 @@ Proof. intros until le. intro Heval. destruct (gen_fmaf_match _) in *; try discriminate. - inversion Heval; subst a; clear Heval. - intro; InvEval. - intro Heval. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. simpl in Heval. inv Heval. TrivialExists. -- cgit From 7c790ecd1c32b529a5e5e5977ce84cfade8e1eb6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 31 Aug 2019 09:16:44 +0200 Subject: some more proofs on integers, preparing for absolute value instruction --- mppa_k1c/ExtValues.v | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 3370fae3..e9c62a8d 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -2,6 +2,24 @@ Require Import Coqlib. Require Import Integers. Require Import Values. +Open Scope Z_scope. + +Definition abs_diff (x y : Z) := Z.abs (x - y). +Definition abs_diff2 (x y : Z) := + if x <=? y then y - x else x - y. +Lemma abs_diff2_correct : + forall x y : Z, (abs_diff x y) = (abs_diff2 x y). +Proof. + intros. + unfold abs_diff, abs_diff2. + unfold Z.leb. + pose proof (Z.compare_spec x y) as Hspec. + inv Hspec. + - rewrite Z.abs_eq; omega. + - rewrite Z.abs_neq; omega. + - rewrite Z.abs_eq; omega. +Qed. + Inductive shift1_4 : Type := | SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. -- cgit From 71c58a8d494eafd847776446b0c246229b2bc9cf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Sep 2019 18:30:25 +0200 Subject: avancement (il faut utiliser Vundef visiblement) --- mppa_k1c/Op.v | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 815d3958..f3ee0577 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1649,6 +1649,27 @@ Proof. - apply Val.offset_ptr_inject; auto. Qed. +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *. + 1,2: inv Hinjvl; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + 2,3: inv Hinjvl; trivial; discriminate. + inv Hinjvl; trivial; inv H0; trivial; + inv H; trivial; discriminate. +Qed. + End EVAL_COMPAT. (** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) @@ -1755,6 +1776,24 @@ Proof. destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. Qed. + +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *. + 1, 2, 4, 5: inv Hlessdef; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + inv Hlessdef; trivial. + inv H0; trivial. + discriminate. +Qed. + End EVAL_LESSDEF. (** Compatibility of the evaluation functions with memory injections. *) -- cgit From 1fbd5d18a9f4398d7ecb9b9ab148a96f575fd1e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Sep 2019 09:51:22 +0200 Subject: Englishification of comments --- mppa_k1c/lib/Machblock.v | 4 ++-- mppa_k1c/lib/Machblockgen.v | 13 ++++--------- 2 files changed, 6 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 30393fd5..2759c49d 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -14,7 +14,7 @@ Require Stacklayout. Require Import Mach. Require Import Linking. -(** instructions "basiques" (ie non control-flow) *) +(** basic instructions (ie no control-flow) *) Inductive basic_inst: Type := | MBgetstack: ptrofs -> typ -> mreg -> basic_inst | MBsetstack: mreg -> ptrofs -> typ -> basic_inst @@ -26,7 +26,7 @@ Inductive basic_inst: Type := Definition bblock_body := list basic_inst. -(** instructions de control flow *) +(** control flow instructions *) Inductive control_flow_inst: Type := | MBcall: signature -> mreg + ident -> control_flow_inst | MBtailcall: signature -> mreg + ident -> control_flow_inst diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index 4dfc309e..db48934e 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -57,12 +57,9 @@ Definition add_to_new_bblock (i:Machblock_inst) : bblock := | MB_cfi i => cfi_bblock i end. -(* ajout d'une instruction en début d'une liste de blocks *) -(* Soit /1\ ajout en tête de block, soit /2\ ajout dans un nouveau block*) -(* bl est vide -> /2\ *) -(* cfi -> /2\ (ajout dans exit)*) -(* basic -> /1\ si header vide, /2\ si a un header *) -(* label -> /1\ (dans header)*) +(** Adding an instruction to the beginning of a bblock list + * Either adding the instruction to the head of the list, + * or create a new bblock with the instruction *) Definition add_to_code (i:Machblock_inst) (bl:code) : code := match bl with | bh::bl0 => match i with @@ -86,8 +83,6 @@ Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := Function trans_code (c: Mach.code) : code := trans_code_rev (List.rev_append c nil) nil. - -(* à finir pour passer des Mach.function au function, etc. *) Definition transf_function (f: Mach.function) : function := {| fn_sig:=Mach.fn_sig f; fn_code:=trans_code (Mach.fn_code f); @@ -103,7 +98,7 @@ Definition transf_program (src: Mach.program) : program := transform_program transf_fundef src. -(** Abstraction de trans_code *) +(** Abstracting trans_code *) Inductive is_end_block: Machblock_inst -> code -> Prop := | End_empty mbi: is_end_block mbi nil -- cgit From 2bf7b92601fd6f33f93609c85a79192f821e6637 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 12:57:15 +0200 Subject: compatibility with OCaml 4.08 --- mppa_k1c/InstructionScheduler.ml | 5 ++--- mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index e182804b..9d3503e2 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -307,9 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order) let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; -(* FIXME DUMMY CODE to placate warnings - *) -let _ = priority_list_scheduler INSTRUCTION_ORDER;; +(* dummy code for placating ocaml's warnings *) +let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; type bundle = int list;; diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml index 33c3c842..9e63c12d 100644 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -74,7 +74,7 @@ let println: pstring -> unit = fun l -> print l; print_newline() let read_line () = - CamlStr (Pervasives.read_line());; + CamlStr (Stdlib.read_line());; exception ImpureFail of pstring;; -- cgit From 5177f34535a70e4335dbab3a66c916c976405df7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 18:27:40 +0200 Subject: Value analysis for non trapping loads --- mppa_k1c/ValueAOp.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 2c9bdf3e..5e9eb455 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,6 +472,26 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. +(* not needed +Theorem eval_static_addressing_sound_none: + forall addr vargs aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> + list_forall2 (vmatch bc) vargs aargs -> + (eval_static_addressing addr aargs) = Vbot. +Proof. + unfold eval_addressing, eval_static_addressing. + intros until aargs. intros Heval_none Hlist. + inv Hlist. + destruct addr; trivial; discriminate. + inv H0. + destruct addr; trivial; discriminate. + inv H2. + destruct addr; trivial; discriminate. + inv H3; + destruct addr; trivial; discriminate. +Qed. + *) + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> -- cgit From e8676a19cf20cf65eb3c57b6621919d3d7ffc065 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Sep 2019 21:22:13 +0200 Subject: forgot this function --- mppa_k1c/ValueAOp.v | 2 -- 1 file changed, 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 5e9eb455..7d84447e 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -472,7 +472,6 @@ Proof. rewrite Ptrofs.add_zero_l; eauto with va. Qed. -(* not needed Theorem eval_static_addressing_sound_none: forall addr vargs aargs, eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> @@ -490,7 +489,6 @@ Proof. inv H3; destruct addr; trivial; discriminate. Qed. - *) Theorem eval_static_operation_sound: forall op vargs m vres aargs, -- cgit From 4284ab56c71cd64ebf6ce22ad13d3cd5533ac7ed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 12:10:11 +0200 Subject: more on notrap --- mppa_k1c/Asmblockgen.v | 19 ++++++++++++------- mppa_k1c/Asmblockgenproof1.v | 34 ++++++++++++++++++++++++++-------- mppa_k1c/lib/Machblock.v | 17 ++++++++++++++--- mppa_k1c/lib/Machblockgen.v | 2 +- mppa_k1c/lib/Machblockgenproof.v | 4 ++++ 5 files changed, 57 insertions(+), 19 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..cd9b3202 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1008,12 +1008,17 @@ Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) do r <- ireg_of dst; transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. -Definition transl_load (chunk: memory_chunk) (addr: addressing) +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match addr with - | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k - | Aindexed2 => transl_load_rrr chunk addr args dst k - | _ => transl_load_rro chunk addr args dst k + match trap with + | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") + | TRAP => + match addr with + | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k + | Aindexed2 => transl_load_rrr chunk addr args dst k + | _ => transl_load_rro chunk addr args dst k + end end. Definition chunk2store (chunk: memory_chunk) := @@ -1073,8 +1078,8 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) | MBop op args res => transl_op op args res k - | MBload chunk addr args dst => - transl_load chunk addr args dst k + | MBload trap chunk addr args dst => + transl_load trap chunk addr args dst k | MBstore chunk addr args src => transl_store chunk addr args src k end. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index e1e2b0b0..ce01041d 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1947,9 +1947,9 @@ Proof. Qed. Lemma transl_load_memory_access_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_load chunk addr args dst k = OK c -> + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr rd, @@ -1958,6 +1958,8 @@ Lemma transl_load_memory_access_ok: /\ forall base ofs rs, exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. Proof. + destruct trap. + { (* TRAP *) intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). @@ -1967,12 +1969,15 @@ Proof. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity | eauto ]. + } + intros until m. intros ADDR TR ? ?. + monadInv TR. Qed. Lemma transl_load_memory_access2_ok: - forall addr chunk args dst k c rs a v m, + forall addr trap chunk args dst k c rs a v m, addr = Aindexed2 -> - transl_load chunk addr args dst k = OK c -> + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, @@ -1983,17 +1988,24 @@ Lemma transl_load_memory_access2_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) intros until m. intros ? TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity | eauto]. + } + { (* NOTRAP *) + intros until m. intros ? TR ? ?. + unfold transl_load in TR. subst. monadInv TR. + } Qed. Lemma transl_load_memory_access2XS_ok: - forall scale chunk args dst k c rs a v m, - transl_load chunk (Aindexed2XS scale) args dst k = OK c -> + forall scale trap chunk args dst k c rs a v m, + transl_load trap chunk (Aindexed2XS scale) args dst k = OK c -> eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, @@ -2004,17 +2016,23 @@ Lemma transl_load_memory_access2XS_ok: /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. Proof. + destruct trap. + { (* TRAP *) intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto | eauto]. + } + { (* NOTRAP *) + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. } Qed. Lemma transl_load_correct: - forall chunk addr args dst k c (rs: regset) m a v, - transl_load chunk addr args dst k = OK c -> + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists rs', diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 2759c49d..5a7f1782 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -20,7 +20,7 @@ Inductive basic_inst: Type := | MBsetstack: mreg -> ptrofs -> typ -> basic_inst | MBgetparam: ptrofs -> typ -> mreg -> basic_inst | MBop: operation -> list mreg -> mreg -> basic_inst - | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst . @@ -207,11 +207,22 @@ Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m: rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> basic_step s fb sp rs m (MBop op args res) rs' m | exec_MBload: - forall addr args a v rs' chunk dst, + forall addr args a v rs' trap chunk dst, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> - basic_step s fb sp rs m (MBload chunk addr args dst) rs' m + basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m + | exec_MBload_notrap1: + forall addr args rs' chunk dst, + eval_addressing ge sp addr rs##args = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m + | exec_MBload_notrap2: + forall addr args a rs' chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m | exec_MBstore: forall chunk addr args src m' a rs', eval_addressing ge sp addr rs##args = Some a -> diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index db48934e..a65b218f 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -33,7 +33,7 @@ Definition trans_inst (i:Mach.instruction) : Machblock_inst := | Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty) | Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst) | Mop op args res => MB_basic (MBop op args res) - | Mload chunk addr args dst => MB_basic (MBload chunk addr args dst) + | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst) | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) | Mlabel l => MB_label l end. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..77db094d 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -483,6 +483,10 @@ Proof. unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; unfold Genv.symbol_address; rewrite symbols_preserved; auto. Qed. -- cgit From 339d7e5ff093a2002aa8c939aece10bafe2914d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:16:05 +0200 Subject: more proofs --- mppa_k1c/Op.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index c75a1a22..7aea2929 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1903,6 +1903,19 @@ Proof. econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. Qed. +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + Lemma eval_operation_inject: forall op vl1 vl2 v1 m1 m2, Val.inject_list f vl1 vl2 -> -- cgit From 7556ba3dc77b1811b8a1063acc45ac1972865363 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Sep 2019 13:58:54 +0200 Subject: more stuff on non trapping loads --- mppa_k1c/Asmblockgenproof.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..828e4665 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,6 +1204,14 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. + - (* MBload notrap1 TODO *) + simpl in EQ0. + discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. + discriminate. + - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. -- cgit From 5a095e968ca040757db22a4bd7cde34b91bf44e1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 5 Sep 2019 14:25:21 +0200 Subject: Removing unused .all, .any, .nall and .none conditions --- mppa_k1c/Asmvliw.v | 13 ------------- mppa_k1c/TargetPrinter.ml | 4 ---- 2 files changed, 17 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 54654abb..54e9c847 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -203,11 +203,6 @@ Inductive itest: Type := | ITgeu (**r Greater Than or Equal Unsigned *) | ITleu (**r Less Than or Equal Unsigned *) | ITgtu (**r Greater Than Unsigned *) - (* Not used yet *) - | ITall (**r All Bits Set in Mask *) - | ITnall (**r Not All Bits Set in Mask *) - | ITany (**r Any Bits Set in Mask *) - | ITnone (**r Not Any Bits Set in Mask *) . Inductive ftest: Type := @@ -909,10 +904,6 @@ Definition compare_int (t: itest) (v1 v2: val): val := | ITgeu => Val_cmpu Cge v1 v2 | ITleu => Val_cmpu Cle v1 v2 | ITgtu => Val_cmpu Cgt v1 v2 - | ITall - | ITnall - | ITany - | ITnone => Vundef end. Definition compare_long (t: itest) (v1 v2: val): val := @@ -929,10 +920,6 @@ Definition compare_long (t: itest) (v1 v2: val): val := | ITgeu => Some (Val_cmplu Cge v1 v2) | ITleu => Some (Val_cmplu Cle v1 v2) | ITgtu => Some (Val_cmplu Cgt v1 v2) - | ITall - | ITnall - | ITany - | ITnone => Some Vundef end in match res with | Some v => v diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5618875f..0c179a07 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -262,10 +262,6 @@ module Target (*: TARGET*) = | ITgeu -> "geu" | ITleu -> "leu" | ITgtu -> "gtu" - | ITall -> "all" - | ITnall -> "nall" - | ITany -> "any" - | ITnone -> "none" let icond oc c = fprintf oc "%s" (icond_name c) -- cgit From 68da36573f9e6e0109095eb74da5f5ec74202b8e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Sep 2019 16:16:53 +0200 Subject: moving forward on K1C --- mppa_k1c/Asm.v | 82 +++++++++++++++++----------------- mppa_k1c/Asmblock.v | 6 +-- mppa_k1c/Asmblockdeps.v | 103 +++++++++++++++++++++++++++---------------- mppa_k1c/Asmblockgen.v | 38 +++++++--------- mppa_k1c/Asmblockgenproof0.v | 30 +++++++------ mppa_k1c/Asmblockgenproof1.v | 54 ++++++++--------------- mppa_k1c/Asmvliw.v | 49 +++++++++++++------- mppa_k1c/Peephole.v | 9 ++-- 8 files changed, 200 insertions(+), 171 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e37176ef 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -107,16 +107,16 @@ Inductive instruction : Type := | Pstsud (rd rs1 rs2: ireg) (** Loads **) - | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) @@ -481,41 +481,41 @@ Definition basic_to_instruction (b: basic) := | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm (** Load *) - | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) - | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) - | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) - - | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) (** Store *) | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 9b4489c5..91e5ac89 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -260,11 +260,11 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec (** Auxiliaries for memory accesses *) -Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset chunk rs rs m m d a ofs. +Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs. -Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg chunk rs rs m m d a ro. +Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro. -Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs chunk rs rs m m d a ro. +Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro. Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..65792d13 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -83,9 +83,9 @@ Coercion OArithRRI32: arith_name_rri32 >-> Funclass. Coercion OArithRRI64: arith_name_rri64 >-> Funclass. Inductive load_op := - | OLoadRRO (n: load_name) (ofs: offset) - | OLoadRRR (n: load_name) - | OLoadRRRXS (n: load_name) + | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset) + | OLoadRRR (n: load_name) (trap: trapping_mode) + | OLoadRRRXS (n: load_name) (trap: trapping_mode) . Coercion OLoadRRO: load_name >-> Funclass. @@ -142,33 +142,39 @@ Definition arith_eval (ao: arith_op) (l: list value) := | _, _ => None end. -Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := +Definition exec_incorrect_load trap chunk := + match trap with + | TRAP => None + | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk)) + end. + +Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := let (ge, fn) := Ge in match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end | _ => None end. -Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v vo) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. -Definition exec_load_deps_regxs (chunk: memory_chunk) (m: mem) (v vo: val) := +Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with - | None => None + | None => exec_incorrect_load trap chunk | Some vl => Some (Val vl) end. Definition load_eval (lo: load_op) (l: list value) := match lo, l with - | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps_offset (load_chunk n) m v ofs - | OLoadRRR n, [Val v; Val vo; Memstate m] => exec_load_deps_reg (load_chunk n) m v vo - | OLoadRRRXS n, [Val v; Val vo; Memstate m] => exec_load_deps_regxs (load_chunk n) m v vo + | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs + | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo + | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo | _, _ => None end. @@ -364,24 +370,47 @@ Proof. Qed. Hint Resolve offset_eq_correct: wlp. +Definition trapping_mode_eq trap1 trap2 := + RET (match trap1, trap2 with + | TRAP, TRAP | NOTRAP, NOTRAP => true + | TRAP, NOTRAP | NOTRAP, TRAP => false + end). +Lemma trapping_mode_eq_correct t1 t2: + WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2. +Proof. + wlp_simplify. + destruct t1; destruct t2; trivial; discriminate. +Qed. +Hint Resolve trapping_mode_eq_correct: wlp. + Definition load_op_eq (o1 o2: load_op): ?? bool := match o1 with - | OLoadRRO n1 ofs1 => - match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end - | OLoadRRR n1 => - match o2 with OLoadRRR n2 => phys_eq n1 n2 | _ => RET false end - | OLoadRRRXS n1 => - match o2 with OLoadRRRXS n2 => phys_eq n1 n2 | _ => RET false end + | OLoadRRO n1 trap ofs1 => + match o2 with + | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2)) + | _ => RET false + end + | OLoadRRR n1 trap => + match o2 with + | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end + | OLoadRRRXS n1 trap => + match o2 with + | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end end. Lemma load_op_eq_correct o1 o2: WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. Proof. destruct o1, o2; wlp_simplify; try discriminate. - - f_equal. pose (Ptrofs.eq_spec ofs ofs0). - rewrite H in *. trivial. - - congruence. - - congruence. + { f_equal. + destruct trap, trap0; simpl in *; trivial; discriminate. + pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. } + all: destruct trap, trap0; simpl in *; trivial; discriminate. Qed. Hint Resolve load_op_eq_correct: wlp. Opaque load_op_eq_correct. @@ -617,21 +646,21 @@ Definition trans_arith (ai: ar_instruction) : inst := Definition trans_basic (b: basic) : inst := match b with | PArith ai => trans_arith ai - | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (PReg (#a) @ PReg pmem @ Enil))] - | PLoadRRR n d a ro => [(#d, Op (Load (OLoadRRR n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PLoadRRRXS n d a ro => [(#d, Op (Load (OLoadRRRXS n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))] + | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] | PLoadQRRO qd a ofs => let (d0, d1) := gpreg_q_expand qd in - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] | PLoadORRO od a ofs => match gpreg_o_expand od with | (d0, d1, d2, d3) => - [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] end | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] | PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] @@ -861,21 +890,21 @@ Local Ltac preg_eq_discr r rd := unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; unfold eval_offset; simpl; auto; - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg *) + destruct i; simpl load_chunk. all: unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. (* Load Reg XS *) + destruct i; simpl load_chunk. all: unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; eexists; split; try split; Simpl; intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. @@ -1537,9 +1566,9 @@ Definition string_of_load_name (n: load_name) : pstring := Definition string_of_load (op: load_op): pstring := match op with - | OLoadRRO n _ => string_of_load_name n - | OLoadRRR n => string_of_load_name n - | OLoadRRRXS n => string_of_load_name n + | OLoadRRO n _ _ => string_of_load_name n + | OLoadRRR n _ => string_of_load_name n + | OLoadRRRXS n _ => string_of_load_name n end. Definition string_of_store_name (n: store_name) : pstring := diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index cd9b3202..fd50f3b4 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -912,12 +912,12 @@ end. Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (PLoadRRO Plw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO Pld rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO Pfls rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO Pfld rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO Plw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO Pld_a rd) base ofs ::i k) + | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k) | _, _ => Error (msg "Asmblockgen.loadind") end. @@ -933,7 +933,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) end. Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := - indexed_memory_access (PLoadRRO Pld dst) base ofs. + indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs. Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := indexed_memory_access (PStoreRRO Psd src) base ofs. @@ -993,32 +993,28 @@ Definition chunk2load (chunk: memory_chunk) := | Many64 => Pld_a end. -Definition transl_load_rro (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access (PLoadRRO (chunk2load chunk) r) addr args k. + transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing) +Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k. + transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k. -Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z) +Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k. + transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k. Definition transl_load (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match trap with - | NOTRAP => Error(msg "Asmblockgen.transl_load NOTRAP TODO") - | TRAP => - match addr with - | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k - | Aindexed2 => transl_load_rrr chunk addr args dst k - | _ => transl_load_rro chunk addr args dst k - end + match addr with + | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k + | Aindexed2 => transl_load_rrr trap chunk addr args dst k + | _ => transl_load_rro trap chunk addr args dst k end. Definition chunk2store (chunk: memory_chunk) := diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index decc3e2e..07c445e2 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -897,34 +897,36 @@ Lemma exec_basic_instr_pc: Proof. intros. destruct b; try destruct i; try destruct i. all: try (inv H; Simpl). - 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]). - 1-10: try (unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]). - 1-10: try (unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - 1-10: try (unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto. - - (* PLoadQRRO *) + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) unfold parexec_load_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PLoadORRO *) + inv H1. Simpl. } + { (* PLoadORRO *) unfold parexec_load_o_offset in H1. destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. - - (* PStoreQRRO *) + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) unfold parexec_store_q_offset in H1. destruct (gpreg_q_expand _) as [r0 r1] in H1. unfold eval_offset in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. - - (* PStoreORRO *) + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) unfold parexec_store_o_offset in H1. destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. unfold eval_offset in H1; try discriminate. @@ -932,7 +934,7 @@ Proof. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. + inv H1. Simpl. reflexivity. } - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ce01041d..68f21541 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1661,9 +1661,9 @@ Qed. Lemma indexed_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) rd m, + forall trap chunk (mk_instr: ireg -> offset -> basic) rd m, (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> forall (base: ireg) ofs k (rs: regset) v, Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> exists rs', @@ -1716,7 +1716,7 @@ Proof. /\ c = indexed_memory_access mk_instr base ofs :: k /\ forall base' ofs' rs', exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_load_offset (chunk_of_type ty) rs' m rd base' ofs'). + exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs'). { unfold loadind in TR. destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. @@ -1784,7 +1784,9 @@ Lemma loadind_ptr_correct: /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. Proof. intros. eapply indexed_load_access_correct; eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. auto. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. + instantiate (1 := TRAP). + auto. Qed. Lemma storeind_ptr_correct: @@ -1877,11 +1879,11 @@ Proof. Qed. Lemma transl_load_access2_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) -> transl_memory_access2 mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1900,11 +1902,11 @@ Proof. Qed. Lemma transl_load_access2XS_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', + forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> ireg_of mro = OK ro -> (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro) -> + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) -> transl_memory_access2XS chunk mk_instr scale args k = OK c -> eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1926,9 +1928,9 @@ Proof. Qed. Lemma transl_load_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', + forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) -> + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> transl_memory_access mk_instr addr args k = OK c -> eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> Mem.loadv chunk m v = Some v' -> @@ -1956,22 +1958,17 @@ Lemma transl_load_memory_access_ok: preg_of dst = IR rd /\ transl_memory_access mk_instr addr args k = OK c /\ forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs. + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs. Proof. - destruct trap. - { (* TRAP *) intros until m. intros ADDR TR ? ?. unfold transl_load in TR. destruct addr; try contradiction. - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity | eauto ]. - } - intros until m. intros ADDR TR ? ?. - monadInv TR. Qed. Lemma transl_load_memory_access2_ok: @@ -1986,21 +1983,14 @@ Lemma transl_load_memory_access2_ok: /\ preg_of mro = IR ro /\ transl_memory_access2 mk_instr addr args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. Proof. - destruct trap. - { (* TRAP *) intros until m. intros ? TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity | eauto]. - } - { (* NOTRAP *) - intros until m. intros ? TR ? ?. - unfold transl_load in TR. subst. monadInv TR. - } Qed. Lemma transl_load_memory_access2XS_ok: @@ -2014,20 +2004,14 @@ Lemma transl_load_memory_access2XS_ok: /\ preg_of mro = IR ro /\ transl_memory_access2XS chunk mk_instr scale args k = OK c /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro. + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro. Proof. - destruct trap. - { (* TRAP *) intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto | eauto]. - } - { (* NOTRAP *) - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. } Qed. Lemma transl_load_correct: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 54654abb..bfe9d77b 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,6 +313,16 @@ Inductive cf_instruction : Type := . (** Loads **) +Definition concrete_default_notrap_load_value chunk := + match chunk with + | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned + | Mint32 => Vint Int.zero + | Mint64 => Vlong Int64.zero + | Many32 | Many64 => Vundef + | Mfloat32 => Vsingle Float32.zero + | Mfloat64 => Vfloat Float.zero + end. + Inductive load_name : Type := | Plb (**r load byte *) | Plbu (**r load byte unsigned *) @@ -327,9 +337,9 @@ Inductive load_name : Type := . Inductive ld_instruction : Type := - | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) - | PLoadRRRXS (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) | PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset) . @@ -1215,10 +1225,16 @@ Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. (** * load/store *) -Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := +Definition parexec_incorrect_load trap chunk d rsw mw := + match trap with + | TRAP => Stuck + | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw + end. + +Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := match (eval_offset ofs) with | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end | _ => Stuck @@ -1263,15 +1279,15 @@ Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a end end. -Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. -Definition parexec_load_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := +Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with - | None => Stuck + | None => parexec_incorrect_load trap chunk d rsw mw | Some v => Next (rsw#d <- v) mw end. @@ -1284,7 +1300,8 @@ Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: | _ => Stuck end. -Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := +Definition parexec_store_reg + (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with | None => Stuck | Some m' => Next rsw m' @@ -1342,7 +1359,7 @@ Definition load_chunk n := | Pfls => Mfloat32 | Pfld => Mfloat64 end. - + Definition store_chunk n := match n with | Psb => Mint8unsigned @@ -1361,12 +1378,12 @@ Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := match bi with | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw - | PLoadRRO n d a ofs => parexec_load_offset (load_chunk n) rsr rsw mr mw d a ofs - | PLoadRRR n d a ro => parexec_load_reg (load_chunk n) rsr rsw mr mw d a ro - | PLoadRRRXS n d a ro => parexec_load_regxs (load_chunk n) rsr rsw mr mw d a ro - | PLoadQRRO d a ofs => + | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs + | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadQRRO d a ofs) => parexec_load_q_offset rsr rsw mr mw d a ofs - | PLoadORRO d a ofs => + | PLoad (PLoadORRO d a ofs) => parexec_load_o_offset rsr rsw mr mw d a ofs | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 7c8f65a8..0611fdda 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Asmvliw. Require Import Values. Require Import Integers. +Require Import AST. Require Compopts. Definition gpreg_q_list : list gpreg_q := @@ -89,8 +90,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := | None => h0 :: (coalesce_mem t0) end - | (PLoadRRO Pld_a rd0 ra0 ofs0), - (PLoadRRO Pld_a rd1 ra1 ofs1) => + | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)), + (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) => match gpreg_q_search rd0 rd1 with | Some rd0rd1 => let zofs0 := Ptrofs.signed ofs0 in @@ -100,8 +101,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic := if coalesce_octuples then match t1 with - | (PLoadRRO Pld_a rd2 ra2 ofs2) :: - (PLoadRRO Pld_a rd3 ra3 ofs3) :: t3 => + | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) :: + (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 => match gpreg_o_search rd0 rd1 rd2 rd3 with | Some octuple => let zofs2 := Ptrofs.signed ofs2 in -- cgit From 22e78b34ca993e0ff1f79c943b16122b1067bd74 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:22:40 +0200 Subject: further --- mppa_k1c/Asmblockgenproof.v | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 828e4665..67f02520 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,9 +1204,26 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - (* MBload notrap1 TODO *) - simpl in EQ0. - discriminate. + - simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = None). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. + intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. - (* MBload notrap2 TODO *) simpl in EQ0. -- cgit From 2b2ad7fc33fecfd77598e485ae0af82be3f23471 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:40:56 +0200 Subject: moving forward with notrap --- mppa_k1c/Asmblockgenproof.v | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 67f02520..15655db6 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1204,30 +1204,18 @@ Local Transparent destroyed_by_op. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl; congruence. - - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = None). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef_none. eapply preg_vals; eauto. eassumption. - intros Haddr. rewrite (sp_val _ _ _ AG) in Haddr. - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. - (* MBload notrap2 TODO *) simpl in EQ0. - discriminate. + admit. - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1253,7 +1241,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Qed. +Admitted. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, -- cgit From a57ba1a8a0036853cac31d9401a6f71b877e70c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 14:50:34 +0200 Subject: a couple "Admitted" and the Coq compiles --- mppa_k1c/PostpassSchedulingproof.v | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 21af276b..867c10c5 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -96,36 +96,42 @@ Proof. Qed. Lemma exec_load_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_load_offset t rs m rd ra ofs = Next rs' m' -> - exec_load_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_reg t rs m rd ra ro = Next rs' m' -> - exec_load_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_load_regxs t rs m rd ra ro = Next rs' m' -> - exec_load_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. Proof. intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. destruct (Mem.loadv _ _ _). - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. Qed. Lemma exec_load_offset_q_pc_var: -- cgit From 74699fa95d096dfc5b9ed7d60aaf1a1338bfc950 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:21:37 +0200 Subject: notrap in mppa_k1c ML code --- mppa_k1c/Asmexpand.ml | 34 +++++++++++++++++----------------- mppa_k1c/PostpassSchedulingOracle.ml | 4 ++-- mppa_k1c/TargetPrinter.ml | 28 ++++++++++++++++------------ 3 files changed, 35 insertions(+), 31 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1e5149fd..5a103915 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -190,10 +190,10 @@ let expand_builtin_memcpy_big sz al src dst = end); cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z)); - cpy tmpbuf 8L (fun x y z -> Pld(x, y, z)) (fun x y z -> Psd(x, y, z)); - cpy tmpbuf 4L (fun x y z -> Plw(x, y, z)) (fun x y z -> Psw(x, y, z)); - cpy tmpbuf 2L (fun x y z -> Plh(x, y, z)) (fun x y z -> Psh(x, y, z)); - cpy tmpbuf 1L (fun x y z -> Plb(x, y, z)) (fun x y z -> Psb(x, y, z)); + cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z)); + cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z)); + cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z)); + cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z)); assert (!remaining = 0L) end else @@ -203,7 +203,7 @@ let expand_builtin_memcpy_big sz al src dst = let lbl = new_label() in emit (Ploopdo (tmpbuf, lbl)); emit Psemi; - emit (Plb (tmpbuf, srcptr, AOff Z.zero)); + emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero)); emit (Paddil (srcptr, srcptr, Z.one)); emit Psemi; emit (Psb (tmpbuf, dstptr, AOff Z.zero)); @@ -223,30 +223,30 @@ let expand_builtin_memcpy sz al args = let expand_builtin_vload_common chunk base ofs res = match chunk, res with | Mint8unsigned, BR(Asmvliw.IR res) -> - emit (Plbu (res, base, AOff ofs)) + emit (Plbu (TRAP, res, base, AOff ofs)) | Mint8signed, BR(Asmvliw.IR res) -> - emit (Plb (res, base, AOff ofs)) + emit (Plb (TRAP, res, base, AOff ofs)) | Mint16unsigned, BR(Asmvliw.IR res) -> - emit (Plhu (res, base, AOff ofs)) + emit (Plhu (TRAP, res, base, AOff ofs)) | Mint16signed, BR(Asmvliw.IR res) -> - emit (Plh (res, base, AOff ofs)) + emit (Plh (TRAP, res, base, AOff ofs)) | Mint32, BR(Asmvliw.IR res) -> - emit (Plw (res, base, AOff ofs)) + emit (Plw (TRAP, res, base, AOff ofs)) | Mint64, BR(Asmvliw.IR res) -> - emit (Pld (res, base, AOff ofs)) + emit (Pld (TRAP, res, base, AOff ofs)) | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> let ofs' = Integers.Ptrofs.add ofs _4 in if base <> res2 then begin - emit (Plw (res2, base, AOff ofs)); - emit (Plw (res1, base, AOff ofs')) + emit (Plw (TRAP, res2, base, AOff ofs)); + emit (Plw (TRAP, res1, base, AOff ofs')) end else begin - emit (Plw (res1, base, AOff ofs')); - emit (Plw (res2, base, AOff ofs)) + emit (Plw (TRAP, res1, base, AOff ofs')); + emit (Plw (TRAP, res2, base, AOff ofs)) end | Mfloat32, BR(Asmvliw.IR res) -> - emit (Pfls (res, base, AOff ofs)) + emit (Pfls (TRAP, res, base, AOff ofs)) | Mfloat64, BR(Asmvliw.IR res) -> - emit (Pfld (res, base, AOff ofs)) + emit (Pfld (TRAP, res, base, AOff ofs)) | _ -> assert false diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fa61d588..41dac766 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -302,7 +302,7 @@ let arith_rec i = | PArithR (i, rd) -> arith_r_rec i (IR rd) let load_rec i = match i with - | PLoadRRO (i, rs1, rs2, imm) -> + | PLoadRRO (trap, i, rs1, rs2, imm) -> { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = [] } | PLoadQRRO(rs, ra, imm) -> @@ -313,7 +313,7 @@ let load_rec i = match i with let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} - | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) -> + | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) -> { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; read_at_id = []; read_at_e1 = [] } diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5618875f..609077c6 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -251,6 +251,10 @@ module Target (*: TARGET*) = | ARegXS _ -> fprintf oc ".xs" | _ -> () + let lsvariant oc = function + | TRAP -> () + | NOTRAP -> output_string oc ".s" + let icond_name = let open Asmvliw in function | ITne | ITneu -> "ne" | ITeq | ITequ -> "eq" @@ -424,18 +428,18 @@ module Target (*: TARGET*) = section oc Section_text (* Load/Store instructions *) - | Plb(rd, ra, adr) -> - fprintf oc " lbs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plbu(rd, ra, adr) -> - fprintf oc " lbz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plh(rd, ra, adr) -> - fprintf oc " lhs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plhu(rd, ra, adr) -> - fprintf oc " lhz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Plw(rd, ra, adr) | Plw_a(rd, ra, adr) | Pfls(rd, ra, adr) -> - fprintf oc " lws%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra - | Pld(rd, ra, adr) | Pfld(rd, ra, adr) | Pld_a(rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra + | Plb(trap, rd, ra, adr) -> + fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plbu(trap, rd, ra, adr) -> + fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plh(trap, rd, ra, adr) -> + fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plhu(trap, rd, ra, adr) -> + fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) -> + fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra | Plq(rd, ra, adr) -> fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra | Plo(rd, ra, adr) -> -- cgit From 5898702ac91da16b487b7debb522a440c296fa93 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 15:53:01 +0200 Subject: more proofs on notrap --- mppa_k1c/Asmblockgenproof1.v | 130 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 124 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 68f21541..55fca89a 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1927,6 +1927,32 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access2XS_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + Lemma transl_load_access_correct: forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', (forall base ofs rs, @@ -1971,21 +1997,65 @@ Proof. | eauto ]. Qed. -Lemma transl_load_memory_access2_ok: - forall addr trap chunk args dst k c rs a v m, - addr = Aindexed2 -> - transl_load trap chunk addr args dst k = OK c -> +Lemma transl_load_memory_access_ok_notrap2: + forall addr chunk args dst k c rs a m, + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_load NOTRAP chunk addr args dst k = OK c -> eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr rd, + preg_of dst = IR rd + /\ transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs. +Proof. + intros until m. intros ADDR TR ? ?. + unfold transl_load in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. +Qed. + +Lemma transl_load_memory_access2_ok: + forall trap chunk args dst k c rs a v m, + transl_load trap chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> Mem.loadv chunk m a = Some v -> exists mk_instr mr0 mro rd ro, args = mr0 :: mro :: nil /\ preg_of dst = IR rd /\ preg_of mro = IR ro - /\ transl_memory_access2 mk_instr addr args k = OK c + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c /\ forall base rs, exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. Proof. - intros until m. intros ? TR ? ?. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity + | eauto]. +Qed. + + +Lemma transl_load_memory_access2_ok_notrap2: + forall chunk args dst k c rs a m, + transl_load NOTRAP chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity @@ -2014,6 +2084,28 @@ Proof. | eauto]. Qed. + +Lemma transl_load_memory_access2XS_ok_notrap2: + forall scale chunk args dst k c rs a m, + transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr scale args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto + | eauto]. +Qed. + Lemma transl_load_correct: forall trap chunk addr args dst k c (rs: regset) m a v, transl_load trap chunk addr args dst k = OK c -> @@ -2040,6 +2132,32 @@ Proof. eapply transl_load_access_correct; eauto with asmgen. Qed. +Lemma transl_load_correct_notrap2: + forall chunk addr args dst k c (rs: regset) m a, + transl_load NOTRAP chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk) + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until a; intros TR EV LOAD. destruct addr. + - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. +Qed. + Lemma transl_store_access2_correct: forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m', args = mr1 :: mro :: nil -> -- cgit From be40bfa8516ab7c2b2f5d5c542af73a4f7b8148e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:02:28 +0200 Subject: more proofs on notrap2 --- mppa_k1c/Asmblockgenproof1.v | 62 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 9 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 55fca89a..c0a05ab3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1901,6 +1901,29 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access2_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + Lemma transl_load_access2XS_correct: forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', args = mr1 :: mro :: nil -> @@ -1924,7 +1947,7 @@ Proof. unfold scale_of_chunk. subst scale. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. + split. trivial. intros. Simpl. Qed. Lemma transl_load_access2XS_correct_notrap2: @@ -1974,6 +1997,27 @@ Proof. split; intros; Simpl. auto. Qed. +Lemma transl_load_access_correct_notrap2: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v; intros INSTR TR EV LOAD. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + Lemma transl_load_memory_access_ok: forall addr trap chunk args dst k c rs a v m, (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> @@ -2144,18 +2188,18 @@ Lemma transl_load_correct_notrap2: Proof. intros until a; intros TR EV LOAD. destruct addr. - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. + eapply transl_load_access_correct_notrap2; eauto with asmgen. Qed. Lemma transl_store_access2_correct: -- cgit From 7df2b7d824f3187f1936685629c06d1028fdc243 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 8 Sep 2019 16:53:08 +0200 Subject: asmblockgen works --- mppa_k1c/Asmblockgenproof.v | 51 +++++++++++++++++++++++++++++++++++++++++---- mppa_k1c/Asmvliw.v | 2 +- 2 files changed, 48 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 15655db6..6baca8c0 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1214,9 +1214,52 @@ Local Transparent destroyed_by_op. destruct t1 as [|h2 t2]; try discriminate. - (* MBload notrap2 TODO *) - simpl in EQ0. - admit. - + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl; congruence. + } - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. @@ -1241,7 +1284,7 @@ Local Transparent destroyed_by_op. eapply agree_undef_regs; eauto with asmgen. simpl; congruence. -Admitted. +Qed. Lemma exec_body_trans: forall l l' rs0 m0 rs1 m1 rs2 m2, diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index bfe9d77b..9508bfbd 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -313,7 +313,7 @@ Inductive cf_instruction : Type := . (** Loads **) -Definition concrete_default_notrap_load_value chunk := +Definition concrete_default_notrap_load_value (chunk : memory_chunk) := match chunk with | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned | Mint32 => Vint Int.zero -- cgit From a1b4ed93ca2b7a244fb5d6d54c0bd0737f618837 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 13 Sep 2019 17:43:27 +0200 Subject: Compatibility fix for Coq 8.7.1 --- mppa_k1c/lib/Machblockgenproof.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 9186e54a..ab7fff74 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -715,17 +715,17 @@ Proof. intro H; destruct c as [|i' c]. { inversion H. } remember (trans_inst i) as ti. destruct ti as [lbl|bi|cfi]. - - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2:{ destruct i; simpl in * |- *; try congruence. } + - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; simpl in * |- *; try congruence ). exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - 10: {exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + Focus 10. exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. } + simpl in H5; congruence. all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From a42baf15372e64f398685aaef079a82ea0db834e Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Sep 2019 14:05:09 +0200 Subject: Timings for Machblockgen, Asmblockgen and postpass scheduling --- mppa_k1c/Asmgen.v | 12 +++++++----- mppa_k1c/Asmgenproof.v | 2 +- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 58e80be1..704a0ac5 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -18,15 +18,17 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. -Require Import Errors. +Require Import Errors String. Local Open Scope error_monad_scope. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. + Definition transf_program (p: Mach.program) : res Asm.program := - let mbp := Machblockgen.transf_program p in - do abp <- Asmblockgen.transf_program mbp; - do abp' <- PostpassScheduling.transf_program abp; - OK (Asm.transf_program abp'). + let mbp := (time "Machblock generation" Machblockgen.transf_program) p in + do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; + do abp' <- (time "PostpassScheduling optimization" PostpassScheduling.transf_program) abp; + OK ((time "Asm generation" Asm.transf_program) abp'). Definition transf_function (f: Mach.function) : res Asm.function := let mbf := Machblockgen.transf_function f in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index e0878c7d..5d7bb81f 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -35,7 +35,7 @@ Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. inversion_clear H. apply bind_inversion in H1. destruct H1. - inversion_clear H. inversion H2. remember (Machblockgen.transf_program p) as mbp. + inversion_clear H. inversion H2. unfold time in *. remember (Machblockgen.transf_program p) as mbp. unfold match_prog; simpl. exists mbp; split. apply Machblockgenproof.transf_program_match; auto. exists x; split. apply Asmblockgenproof.transf_program_match; auto. -- cgit From 7f1025fa2da08e68b839b7b6ea89771822dcfe83 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 18 Sep 2019 14:26:17 +0200 Subject: Detailing oracle/vérificateur in the timings MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- mppa_k1c/Asmgen.v | 2 +- mppa_k1c/PostpassSchedulingOracle.ml | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 704a0ac5..c3588871 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -27,7 +27,7 @@ Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; - do abp' <- (time "PostpassScheduling optimization" PostpassScheduling.transf_program) abp; + do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp; OK ((time "Asm generation" Asm.transf_program) abp'). Definition transf_function (f: Mach.function) : res Asm.function := diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index fa61d588..327901f3 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -991,4 +991,5 @@ let rec bundles_to_coq_schedule = function (** Called schedule function from Coq *) -let schedule bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto +let schedule_notime bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto +let schedule bb = Timing.time_coq ('P'::('o'::('s'::('t'::('p'::('a'::('s'::('s'::('S'::('c'::('h'::('e'::('d'::('u'::('l'::('i'::('n'::('g'::(' '::('o'::('r'::('a'::('c'::('l'::('e'::([])))))))))))))))))))))))))) schedule_notime bb -- cgit From 1801685f8352b7a120d87d5b529d290728129529 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 20 Sep 2019 14:32:33 +0200 Subject: __builtin_bswap16, 32 and 64 --- mppa_k1c/Asmexpand.ml | 63 +++++++++++++++++++++++++++------------------------ mppa_k1c/CBuiltins.ml | 8 ++----- 2 files changed, 35 insertions(+), 36 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 1e5149fd..9c256bd0 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -345,34 +345,32 @@ let expand_int64_arith conflict rl fn = assert false (* Byte swaps. There are no specific instructions, so we use standard, not-very-efficient formulas. *) -let expand_bswap16 d s = assert false +let expand_bswap16 d s = let open Asmvliw in (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) -(*emit (Pandiw(X31, X s, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _8)); - emit (Psrliw(d, X s, _8)); - emit (Pandiw(d, X d, coqint_of_camlint 0xFFl)); - emit (Porw(d, X X31, X d)) -*) + emit (Pandiw(GPR32, s, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Psrliw(d, s, _8)); emit Psemi; + emit (Pandiw(d, d, coqint_of_camlint 0xFFl)); + emit (Porw(d, GPR32, d)); emit Psemi -let expand_bswap32 d s = assert false +let expand_bswap32 d s = let open Asmvliw in (* d = (s << 24) | (((s >> 8) & 0xFF) << 16) | (((s >> 16) & 0xFF) << 8) | (s >> 24) *) -(*emit (Pslliw(X1, X s, coqint_of_camlint 24l)); - emit (Psrliw(X31, X s, _8)); - emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _16)); - emit (Porw(X1, X X1, X X31)); - emit (Psrliw(X31, X s, _16)); - emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Pslliw(X31, X X31, _8)); - emit (Porw(X1, X X1, X X31)); - emit (Psrliw(X31, X s, coqint_of_camlint 24l)); - emit (Porw(d, X X1, X X31)) -*) - -let expand_bswap64 d s = assert false + emit (Pslliw(GPR16, s, coqint_of_camlint 24l)); emit Psemi; + emit (Psrliw(GPR32, s, _8)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _16)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR31)); emit Psemi; + emit (Psrliw(GPR32, s, _16)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR32)); emit Psemi; + emit (Psrliw(GPR32, s, coqint_of_camlint 24l)); emit Psemi; + emit (Porw(d, GPR16, GPR32)); emit Psemi + +let expand_bswap64 d s = let open Asmvliw in (* d = s << 56 | (((s >> 8) & 0xFF) << 48) | (((s >> 16) & 0xFF) << 40) @@ -381,17 +379,16 @@ let expand_bswap64 d s = assert false | (((s >> 40) & 0xFF) << 16) | (((s >> 48) & 0xFF) << 8) | s >> 56 *) -(*emit (Psllil(X1, X s, coqint_of_camlint 56l)); + emit (Psllil(GPR16, s, coqint_of_camlint 56l)); emit Psemi; List.iter (fun (n1, n2) -> - emit (Psrlil(X31, X s, coqint_of_camlint n1)); - emit (Pandil(X31, X X31, coqint_of_camlint 0xFFl)); - emit (Psllil(X31, X X31, coqint_of_camlint n2)); - emit (Porl(X1, X X1, X X31))) + emit (Psrlil(GPR32, s, coqint_of_camlint n1)); emit Psemi; + emit (Pandil(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Psllil(GPR32, GPR32, coqint_of_camlint n2)); emit Psemi; + emit (Porl(GPR16, GPR16, GPR32)); emit Psemi;) [(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)]; - emit (Psrlil(X31, X s, coqint_of_camlint 56l)); - emit (Porl(d, X X1, X X31)) -*) + emit (Psrlil(GPR32, s, coqint_of_camlint 56l)); emit Psemi; + emit (Porl(d, GPR16, GPR32)); emit Psemi (* Handling of compiler-inlined builtins *) let last_system_register = 511l @@ -477,6 +474,12 @@ let expand_builtin_inline name args res = let open Asmvliw in emit (Palclrd(res, addr)) | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> emit (Palclrw(res, addr)) + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + expand_bswap16 res a1 + | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + expand_bswap32 res a1 + | "__builtin_bswap64", [BA(IR src)], BR(IR res) -> + expand_bswap64 res src (* Byte swaps *) (*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index 235496c5..a91119b1 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -96,12 +96,8 @@ let builtins = { (* Synchronization *) (* "__builtin_fence", - (TVoid [], [], false); - (* Integer arithmetic *) - "__builtin_bswap64", - (TInt(IULongLong, []), - [TInt(IULongLong, [])], false); - (* Float arithmetic *) + (TVoid [], [], false); *) +(* (* Float arithmetic *) "__builtin_fmadd", (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); -- cgit From c5b3084dbb231fd8a97789799fd99d7012d59bed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 16:38:43 +0200 Subject: extraction problems --- mppa_k1c/Asmgen.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index c3588871..e64e3df3 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -22,7 +22,8 @@ Require Import Errors String. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := + Compiler.time. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in -- cgit From adc142066720798ca2e6f7709de6fba93559a336 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 17:07:16 +0200 Subject: fix compiling --- mppa_k1c/Asmgen.v | 4 ++-- mppa_k1c/Asmgenproof.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index e64e3df3..8875a4ac 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -19,11 +19,11 @@ Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. Require Import PostpassScheduling. Require Import Errors String. +Require Compopts. Local Open Scope error_monad_scope. -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := - Compiler.time. +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f. Definition transf_program (p: Mach.program) : res Asm.program := let mbp := (time "Machblock generation" Machblockgen.transf_program) p in diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 5d7bb81f..7388f6da 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -35,7 +35,7 @@ Proof. intros p tp H. unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. inversion_clear H. apply bind_inversion in H1. destruct H1. - inversion_clear H. inversion H2. unfold time in *. remember (Machblockgen.transf_program p) as mbp. + inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. unfold match_prog; simpl. exists mbp; split. apply Machblockgenproof.transf_program_match; auto. exists x; split. apply Asmblockgenproof.transf_program_match; auto. -- cgit From 3e32784577f1a33d0a4cd19d92ccc971996a73ec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Sep 2019 20:10:15 +0200 Subject: fix Focus -> { ... } --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 02d154c7..91be5e2e 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -723,13 +723,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 10. exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From a8e2039a772da0fcfd484b7445de8cc093be5d2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 23 Sep 2019 14:17:12 +0200 Subject: is_trapping_op_sound --- mppa_k1c/Op.v | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 7aea2929..92061d04 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1030,6 +1030,34 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + constructor. Qed. +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Omod | Omodl | Omodu | Omodlu + | Oshrximm _ | Oshrxlimm _ + | Ointoffloat | Ointuoffloat + | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat + | Olongofsingle | Olonguofsingle + | Osingleofint | Osingleofintu + | Osingleoflong | Osingleoflongu + | Ofloatoflong | Ofloatoflongu => true + | _ => false + end. + +Lemma is_trapping_op_sound: + forall op vl sp m, + op <> Omove -> + is_trapping_op op = false -> + (List.length vl) = (List.length (fst (type_of_operation op))) -> + eval_operation genv sp op vl m <> None. +Proof. + destruct op; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. End SOUNDNESS. (** * Manipulating and transforming operations *) -- cgit From 4bcba7bdbdaa4afa9dafd5506c980afd711f53f7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 24 Sep 2019 14:20:42 +0200 Subject: (#161) - Fixing vararg bug --- mppa_k1c/Asmexpand.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 9c256bd0..67ef6f52 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -507,8 +507,8 @@ let expand_instruction instr = expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; emit Psemi; let va_ofs = - sz in - (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *) + let extra_ofs = if n <= _nbregargs_ then 0 else ((n - _nbregargs_) * wordsize) in + Z.add sz (Z.of_sint extra_ofs) in vararg_start_ofs := Some va_ofs; save_arguments n va_ofs end else begin -- cgit From 222cb525b22394077e32fa4e107b033ca2cb6d39 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:20 +0200 Subject: Asmblockgenproof renaming fpok --> ep --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index c44ef3ff..156354c4 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -354,7 +354,7 @@ Record codestate := pbody1: list basic; pbody2: list basic; pctl: option control; - fpok: bool; + ep: bool; rem: list AB.bblock; cur: option bblock }. @@ -379,7 +379,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pbody1 := tbc; pbody2 := (extract_basic tbi); pctl := extract_ctl tbi; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} @@ -400,7 +400,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pbody1 := tbdy; pbody2 := extract_basic tex; pctl := extract_ctl tex; - fpok := ep; + ep := ep; rem := tc; cur := Some tbb |} (Asmvliw.State rs m) @@ -422,7 +422,7 @@ Lemma transl_blocks_nonil: transl_blocks f (bb::c) ep = OK tc -> exists tbb tc', tc = tbb :: tc'. Proof. - intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. destruct (extract_ctl x2). - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - destruct x1; simpl; eauto. @@ -469,7 +469,7 @@ Lemma transl_blocks_distrib: -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) /\ transl_blocks f c false = OK tc. Proof. - intros until ep. intros TLBS Hbuiltin. + intros until ep0. intros TLBS Hbuiltin. destruct bb as [hd bdy ex]. monadInv TLBS. monadInv EQ. exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. @@ -611,7 +611,7 @@ Proof. eapply transl_instr_control_nobuiltin; eauto. intros (Hth & Htbdy & Htexit). exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep. + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep0. repeat split. 1-2: econstructor; eauto. { destruct (MB.header bb). eauto. discriminate. } eauto. unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. @@ -1032,7 +1032,7 @@ Lemma step_simu_basic: match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists rs2 m2 l cs2 tbdy', cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |} + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} /\ tbdy = l ++ tbdy' /\ exec_body tge l rs1 m1 = Next rs2 m2 /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). @@ -1098,7 +1098,7 @@ Proof. (* Opaque loadind. *) (* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep eqn:EPeq. + destruct ep0 eqn:EPeq. (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1253,7 +1253,7 @@ Qed. Inductive exec_header: codestate -> codestate -> Prop := | exec_header_cons: forall cs1, exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. @@ -1293,14 +1293,14 @@ Lemma step_simu_body: match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists rs2 m2 cs2 ep, cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; - pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |} + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). Proof. intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - exists rs1, m1, cs1, (fpok cs1). + exists rs1, m1, cs1, (ep cs1). inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). econstructor; eauto. - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. -- cgit From c229731bdd49255cfb69536ec758eb3004554ce0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 16:58:32 +0200 Subject: Tiny clean --- mppa_k1c/Archi.v | 1 - 1 file changed, 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index cdcf58c3..69b32c7c 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -17,7 +17,6 @@ (** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) Require Import ZArith List. -(*From Flocq*) Require Import Binary Bits. Definition ptr64 := true. -- cgit From 541e60e0570b70813c2ace604a1535bb4d79aa2b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 1 Oct 2019 17:29:40 +0200 Subject: Asmblockgenproof : cur rewriting --- mppa_k1c/Asmblockgenproof.v | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 156354c4..1c5ad19c 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -356,7 +356,7 @@ Record codestate := pctl: option control; ep: bool; rem: list AB.bblock; - cur: option bblock }. + cur: bblock }. (* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) @@ -381,7 +381,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := pctl := extract_ctl tbi; ep := ep; rem := tc; - cur := Some tbb + cur := tbb |} . @@ -402,7 +402,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := pctl := extract_ctl tex; ep := ep; rem := tc; - cur := Some tbb |} + cur := tbb |} (Asmvliw.State rs m) . @@ -596,7 +596,7 @@ Theorem match_state_codestate: /\ transl_blocks f (bb::c) ep = OK (tbb::tc) /\ body tbb = pbody1 cs ++ pbody2 cs /\ exit tbb = pctl cs - /\ cur cs = Some tbb /\ rem cs = tc + /\ cur cs = tbb /\ rem cs = tc /\ pstate cs = abs. Proof. intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. @@ -611,7 +611,7 @@ Proof. eapply transl_instr_control_nobuiltin; eauto. intros (Hth & Htbdy & Htexit). exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep0. + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. repeat split. 1-2: econstructor; eauto. { destruct (MB.header bb). eauto. discriminate. } eauto. unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. @@ -719,7 +719,7 @@ Theorem step_simu_control: Genv.find_funct_ptr tge fb = Some (Internal fn) -> pstate cs2 = (Asmvliw.State rs2 m2) -> pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> - cur cs2 = Some tbb -> + cur cs2 = tbb -> match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> @@ -731,7 +731,7 @@ Proof. intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. inv ESTEP. - inv MCS. inv MAS. simpl in *. - inv Hcur. inv Hpstate. + inv Hpstate. destruct ctl. + (* MBcall *) destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. @@ -962,7 +962,7 @@ Proof. econstructor; eauto. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur. + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. (* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) intros (TLB & TLBS). *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. @@ -1446,8 +1446,8 @@ Proof. 9: eapply MCS'. all: simpl. 10: eapply ESTEP. all: simpl; eauto. - rewrite Hpbody2. rewrite Hpctl. rewrite Hcur. - { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. erewrite exec_body_pc; eauto. } intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). @@ -1472,7 +1472,7 @@ Proof. assert (f1 = f0) by congruence. subst f0. rewrite PCeq in Hrs1pc. inv Hrs1pc. exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. - inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. eapply find_bblock_tail; eauto. Qed. -- cgit From 5ffa8534d09272e5f44c51193e74cffdbc2b043c Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 7 Oct 2019 15:44:20 +0200 Subject: Icond --- mppa_k1c/Op.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index f9a774e8..ce9a5dcd 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,6 +51,12 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) +Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. +Proof. + generalize comparison_eq int_eq int64_eq. + decide equality. +Defined. + Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From 75326127cbb4d57d435b28651ef65dcd2a0b8ce5 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:49:31 +0200 Subject: Fixing fp_is_parent too weak (#165) --- mppa_k1c/Asmblockgen.v | 4 +- mppa_k1c/Asmblockgenproof.v | 3605 ++++++++++++++++++++++--------------------- 2 files changed, 1811 insertions(+), 1798 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index ade84e7b..bbe24fec 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1111,10 +1111,12 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := match i with + | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP) | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | _ => false + | MBload chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBstore chunk addr args res => before end. (** This is the naive definition, which is not tail-recursive unlike the other backends *) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1c5ad19c..ad4d2932 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,1797 +1,1808 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for RISC-V generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. -Require Import Axioms. - -Module MB := Machblock. -Module AB := Asmvliw. - -Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Machblock.program. -Variable tprog: Asmvliw.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -(** * Properties of control flow *) - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -Lemma gen_bblocks_label: - forall hd bdy ex tbb tc, - gen_bblocks hd bdy ex = tbb::tc -> - header tbb = hd. -Proof. - intros until tc. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma gen_bblocks_label2: - forall hd bdy ex tbb1 tbb2, - gen_bblocks hd bdy ex = tbb1::tbb2::nil -> - header tbb2 = nil. -Proof. - intros until tbb2. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma in_dec_transl: - forall lbl hd, - (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). -Proof. - intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. -Qed. - -Lemma transl_is_label: - forall lbl bb tbb f ep tc, - transl_block f bb ep = OK (tbb::tc) -> - is_label lbl tbb = MB.is_label lbl bb. -Proof. - intros until tc. intros TLB. - destruct tbb as [thd tbdy tex]; simpl in *. - monadInv TLB. - unfold is_label. simpl. - apply gen_bblocks_label in H0. simpl in H0. subst. - rewrite in_dec_transl. auto. -Qed. - -Lemma transl_is_label_false2: - forall lbl bb f ep tbb1 tbb2, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb2 = false. -Proof. - intros until tbb2. intros TLB. - destruct tbb2 as [thd tbdy tex]; simpl in *. - monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. - apply is_label_correct_false. simpl. auto. -Qed. - -Lemma transl_is_label2: - forall f bb ep tbb1 tbb2 lbl, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb1 = MB.is_label lbl bb - /\ is_label lbl tbb2 = false. -Proof. - intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. -Qed. - -Lemma transl_block_nonil: - forall f c ep tc, - transl_block f c ep = OK tc -> - tc <> nil. -Proof. - intros. monadInv H. unfold gen_bblocks. - destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. - all: discriminate. -Qed. - -Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, - ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). -Proof. - intros. intro. monadInv H. - unfold gen_bblocks in H0. - destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. - all: discriminate. -Qed. - -Lemma find_label_transl_false: - forall x f lbl bb ep x', - transl_block f bb ep = OK x -> - MB.is_label lbl bb = false -> - find_label lbl (x++x') = find_label lbl x'. -Proof. - intros until x'. intros TLB MBis; simpl; auto. - destruct x as [|x0 x1]; simpl; auto. - destruct x1 as [|x1 x2]; simpl; auto. - - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. - - destruct x2 as [|x2 x3]; simpl; auto. - + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. - erewrite transl_is_label_false2; eauto. - + apply transl_block_limit in TLB. destruct TLB. -Qed. - -Lemma transl_blocks_label: - forall lbl f c tc ep, - transl_blocks f c ep = OK tc -> - match MB.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. - destruct (MB.is_label lbl a) eqn:MBis. - - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } - simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. - rewrite ABis. - eexists. eexists. split; eauto. simpl transl_blocks. - assert (MB.header a <> nil). - { apply MB.is_label_correct_true in MBis. - destruct (MB.header a). contradiction. discriminate. } - destruct (MB.header a); try contradiction. - rewrite EQ. simpl. rewrite EQ1. simpl. auto. - - apply IHc in EQ1. destruct (MB.find_label lbl c). - + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. - erewrite find_label_transl_false; eauto. - + erewrite find_label_transl_false; eauto. -Qed. - -Lemma find_label_nil: - forall bb lbl c, - header bb = nil -> - find_label lbl (bb::c) = find_label lbl c. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. subst. - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { erewrite <- is_label_correct_false. simpl. auto. } - rewrite H. auto. -Qed. - -Lemma transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match MB.find_label lbl f.(MB.fn_code) with - | None => find_label lbl tf.(fn_blocks) = None - | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. - eapply transl_blocks_label; eauto. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated Asm code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - MB.find_label lbl f.(MB.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros (tc & A & B). - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -(* NB: the hypothesis in comment on [b] is not needed in the proof ! -*) -Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmblockgenproof0.return_address_exists; eauto. - -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. -(* rewrite transl_code'_transl_code in EQ0. *) - exists x; exists true; split; auto. (* unfold fn_code. *) - repeat constructor. - - exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - The invariant is the [match_states] predicate below, which includes: -- The Asm code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and Asm register values agree. -*) - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the Asm side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Machsem.Returnstate] to [Machsem.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) - - -Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of MFP). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Machblock.State s fb sp c ms m) - (Asmvliw.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Machblock.Callstate s fb ms m) - (Asmvliw.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machblock.Returnstate s ms m) - (Asmvliw.State rs m'). - -Record codestate := - Codestate { pstate: state; - pheader: list label; - pbody1: list basic; - pbody2: list basic; - pctl: option control; - ep: bool; - rem: list AB.bblock; - cur: bblock }. - -(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) - -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m0) - (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) - (TIC: transl_instr_control f (MB.exit bb) = OK tbi) - (TBLS: transl_blocks f c false = OK tc) -(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) - (AG: agree ms sp rs0) - (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) - , - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - {| pstate := (Asmvliw.State rs0 m0); - pheader := (MB.header bb); - pbody1 := tbc; - pbody2 := (extract_basic tbi); - pctl := extract_ctl tbi; - ep := ep; - rem := tc; - cur := tbb - |} -. - -Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := - | match_asmstate_some: - forall rs f tf tc m tbb ofs ep tbdy tex lhd - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (TRANSF: transf_function f = OK tf) - (PCeq: rs PC = Vptr fb ofs) - (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) -(* (HDROK: header tbb = lhd) *) - , - match_asmstate fb - {| pstate := (Asmvliw.State rs m); - pheader := lhd; - pbody1 := tbdy; - pbody2 := extract_basic tex; - pctl := extract_ctl tex; - ep := ep; - rem := tc; - cur := tbb |} - (Asmvliw.State rs m) -. - -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - -Lemma transl_blocks_nonil: - forall f bb c tc ep, - transl_blocks f (bb::c) ep = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. - intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - -Lemma no_builtin_preserved: - forall f ex x2, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x2 -> - (exists i, extract_ctl x2 = Some (PCtlFlow i)) - \/ extract_ctl x2 = None. -Proof. - intros until x2. intros Hbuiltin TIC. - destruct ex. - - destruct c. - (* MBcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBtailcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBbuiltin *) - + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). - apply Hbuiltin. contradict H; auto. - (* MBgoto *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBcond *) - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. - * unfold transl_opt_compuimm. exploreInst; simpl; eauto. - * unfold transl_opt_compluimm. exploreInst; simpl; eauto. - * unfold transl_comp_float64. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. - * unfold transl_comp_float32. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - (* MBjumptable *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBreturn *) - + simpl in TIC. monadInv TIC. simpl. eauto. - - monadInv TIC. simpl; auto. -Qed. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) - /\ transl_blocks f c false = OK tc. -Proof. - intros until ep0. intros TLBS Hbuiltin. - destruct bb as [hd bdy ex]. - monadInv TLBS. monadInv EQ. - exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. - - destruct H as [i Hectl]. - unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. - simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite Hectl. auto. - - unfold gen_bblocks in H0. rewrite H in H0. - destruct x1 as [|bi x1]. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - (tbdy <> nil \/ extract_ctl tex <> None) -> - (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = tbdy ++ extract_basic tex - /\ exit tbb = extract_ctl tex. -Proof. - intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl tex) eqn:ECTL. - - destruct c. - + destruct i; try (inv GENB; simpl; auto; fail). - assert False. eapply Hnobuiltin. eauto. destruct H. - + inv GENB. simpl. auto. - - inversion Hnonil. - + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. - + contradict H; simpl; auto. -Qed. - -Lemma transl_instr_basic_nonil: - forall k f bi ep x, - transl_instr_basic f bi ep k = OK x -> - x <> nil. -Proof. - intros until x. intros TIB. - destruct bi. - - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. - - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. - - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. - - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. - unfold transl_cond_op in EQ0. exploreInst; try discriminate. - unfold transl_cond_float64. exploreInst; try discriminate. - unfold transl_cond_notfloat64. exploreInst; try discriminate. - unfold transl_cond_float32. exploreInst; try discriminate. - unfold transl_cond_notfloat32. exploreInst; try discriminate. - - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. - - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. -Qed. - -Lemma transl_basic_code_nonil: - forall bdy f x ep, - bdy <> nil -> - transl_basic_code f bdy ep = OK x -> - x <> nil. -Proof. - induction bdy as [|bi bdy]. - intros. contradict H0; auto. - destruct bdy as [|bi2 bdy]. - - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. - - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. - monadInv TBC. - assert (x0 <> nil). - eapply IHbdy; eauto. subst bdy'. discriminate. - eapply transl_instr_basic_nonil; eauto. -Qed. - -Lemma transl_instr_control_nonil: - forall ex f x, - ex <> None -> - transl_instr_control f ex = OK x -> - extract_ctl x <> None. -Proof. - intros ex f x Hnonil TIC. - destruct ex as [ex|]. - - clear Hnonil. destruct ex. - all: try (simpl in TIC; exploreInst; discriminate). - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. - * unfold transl_opt_compuimm. exploreInst; try discriminate. - * unfold transl_opt_compluimm. exploreInst; try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. - - contradict Hnonil; auto. -Qed. - -Lemma transl_instr_control_nobuiltin: - forall f ex x, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x -> - (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). -Proof. - intros until x. intros Hnobuiltin TIC. intros until res. - unfold transl_instr_control in TIC. exploreInst. - all: try discriminate. - - assert False. eapply Hnobuiltin; eauto. destruct H. - - unfold transl_cbranch in TIC. exploreInst. - all: try discriminate. - * unfold transl_opt_compuimm. exploreInst. all: try discriminate. - * unfold transl_opt_compluimm. exploreInst. all: try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. -Qed. - -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m, - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (MB.body bb <> nil \/ MB.exit bb <> None) -> - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - match_states mbs abs -> - exists cs fb f tbb tc ep, - match_codestate fb mbs cs /\ match_asmstate fb cs abs - /\ Genv.find_funct_ptr ge fb = Some (Internal f) - /\ transl_blocks f (bb::c) ep = OK (tbb::tc) - /\ body tbb = pbody1 cs ++ pbody2 cs - /\ exit tbb = pctl cs - /\ cur cs = tbb /\ rem cs = tc - /\ pstate cs = abs. -Proof. - intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. - inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. - monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. - { inversion Hnotempty. - - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). - left. eapply transl_basic_code_nonil; eauto. - - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). - right. eapply transl_instr_control_nonil; eauto. } - eapply transl_instr_control_nobuiltin; eauto. - intros (Hth & Htbdy & Htexit). - exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. - repeat split. 1-2: econstructor; eauto. - { destruct (MB.header bb). eauto. discriminate. } eauto. - unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. - rewrite TLBS. simpl. rewrite H2. - all: simpl; auto. -Qed. - -Definition mb_remove_body (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma exec_straight_pnil: - forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb ep tbb, - (MB.body bb <> nil \/ MB.exit bb <> None) -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - transl_block f bb ep = OK (tbb :: nil) -> - exists c c', - transl_basic_code f (MB.body bb) ep = OK c - /\ transl_instr_control f (MB.exit bb) = OK c' - /\ body tbb = c ++ extract_basic c' - /\ exit tbb = extract_ctl c'. -Proof. - intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. -Qed. - -Lemma nextblock_preserves: - forall rs rs' bb r, - rs' = nextblock bb rs -> - data_preg r = true -> - rs r = rs' r. -Proof. - intros. destruct r; try discriminate. - subst. Simpl. -(* - subst. Simpl. *) -Qed. - -Lemma cons3_app {A: Type}: - forall a b c (l: list A), - a :: b :: c :: l = (a :: b :: c :: nil) ++ l. -Proof. - intros. simpl. auto. -Qed. - -Lemma exec_straight_opt_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight_opt tge c rs1 m1 c' rs2 m2 -> - exists body, - exec_body tge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. intros EXES. - inv EXES. - - exists nil. split; auto. - - eapply exec_straight_body2. auto. -Qed. - -Lemma extract_basics_to_code: - forall lb c, - extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -Lemma extract_ctl_basics_to_code: - forall lb c, - extract_ctl (basics_to_code lb ++ c) = extract_ctl c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -(* Lemma goto_label_inv: - forall fn tbb l rs m b ofs, - rs PC = Vptr b ofs -> - goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. -Proof. - intros. - unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. - exploreInst; auto. - unfold nextblock. rewrite Pregmap.gss. - -Qed. - - -Lemma exec_control_goto_label_inv: - exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> - exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. -Proof. -Qed. *) - -Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, - MB.body bb' = nil -> - (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> - Genv.find_funct_ptr tge fb = Some (Internal fn) -> - pstate cs2 = (Asmvliw.State rs2 m2) -> - pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> - cur cs2 = tbb -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> - (exists rs3 m3 rs4 m4, - exec_body tge tbdy2 rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. - inv ESTEP. - - inv MCS. inv MAS. simpl in *. - inv Hpstate. - destruct ctl. - + (* MBcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct s1 as [rf|fid]; simpl in H7. - * (* Indirect call *) - monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. - revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - { econstructor; eauto. } - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. - - * (* Direct call *) - monadInv H1. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - econstructor; eauto. - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. - destruct s1 as [rf|fid]; simpl in H13. - * monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - - assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - { simpl. eauto. } - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). - { clear - EQ. destruct x; repeat split; try discriminate. - all: unfold ireg_of in EQ; destruct rf; try discriminate. } - Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. - * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } - + (* MBbuiltin (contradiction) *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. - remember (nextblock tbb rs2) as rs2'. - (* inv AT. monadInv H4. *) - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - exploit find_label_goto_label. - eauto. eauto. - instantiate (2 := rs2'). - { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } - eauto. - intros (tc' & rs' & GOTO & AT2 & INV). - - eexists. eexists. repeat eexists. repeat split. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. - econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. - eapply agree_exten; eauto with asmgen. - assert (forall r : preg, r <> PC -> rs' r = rs2 r). - { intros. destruct r. - - destruct g. all: rewrite INV; Simpl; auto. -(* - destruct g. all: rewrite INV; Simpl; auto. *) - - rewrite INV; Simpl; auto. - - contradiction. } - eauto with asmgen. - congruence. - + (* MBcond *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - * (* MBcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. - 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. - unfold Val.offset_ptr. rewrite PCeq. eauto. - intros (tc' & rs3 & GOTOL & TLPC & Hrs3). - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - - * (* MBcond false *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - - exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - monadInv H1. - generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. - - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - - repeat eexists. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. - econstructor; eauto. - eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. - { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. - destruct (preg_eq r' GPR63). subst. contradiction. - destruct (preg_eq r' GPR62). subst. contradiction. - destruct r'; Simpl. } - discriminate. - + (* MBreturn *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - assert (f1 = f) by congruence. subst f1. - - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. -(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). - *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. -(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) - monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. - simpl. repeat eexists. - econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - assert (f = f0) by congruence. subst f0. econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - discriminate. -Qed. - -Definition mb_remove_first (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. - -Lemma exec_straight_body: - forall c c' lc rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 c' rs2 m2 -> - code_to_basics c = Some lc -> - exists l ll, - c = l ++ c' - /\ code_to_basics l = Some ll - /\ exec_body tge ll rs1 m1 = Next rs2 m2. -Proof. - induction c; try (intros; inv H; fail). - intros until m2. intros EXES CTB. inv EXES. - - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. - - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. - eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. - exists (i ::g l'),(i::ll). repeat (split; simpl; auto). - rewrite CTB. auto. - rewrite H1. auto. -Qed. - -Lemma basics_to_code_app: - forall c l x ll, - basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - c = ll ++ x. -Proof. - intros. apply (f_equal code_to_basics) in H. - erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. - rewrite code_to_basics_id in H. inv H. auto. -Qed. - -Lemma basics_to_code_app2: - forall i c l x ll, - (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - i :: c = ll ++ x. -Proof. - intros until ll. intros. - exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. - all: eauto. -Qed. - -Lemma step_simu_basic: - forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> - basic_step ge s fb sp ms m bi ms' m' -> - pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 l cs2 tbdy', - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} - /\ tbdy = l ++ tbdy' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). -Proof. - intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. - simpl in *. inv Hpstate. - rewrite Hbody in TBC. monadInv TBC. - inv BSTEP. - - (* MBgetstack *) - simpl in EQ0. - unfold Mach.load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - exploit loadind_correct; eauto with asmgen. - intros (rs2 & EXECS & Hrs'1 & Hrs'2). - eapply exec_straight_body in EXECS. - 2: eapply code_to_basics_id; eauto. - destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). - exists rs2, m1, Hlbi. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - rewrite <- Hheadereq. *) subst. - - eapply match_codestate_intro; eauto. simpl. simpl in EQ. (* { destruct (MB.header bb); auto. } *) - eapply agree_set_mreg; eauto with asmgen. - intro Hep. simpl in Hep. inv Hep. - - (* MBsetstack *) - simpl in EQ0. - unfold Mach.store_stack in H. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - exploit storeind_correct; eauto with asmgen. - rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs', m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - - eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - - (* MBgetparam *) - simpl in EQ0. - - assert (f0 = f) by congruence; subst f0. - unfold Mach.load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. - - (* Opaque loadind. *) -(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) - monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep0 eqn:EPeq. - (* RTMP contains parent *) - + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & BTC & CTB & EXECB). - exists rs2, m1, ll. eexists. - eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - { eapply basics_to_code_app; eauto. } - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - (* rewrite <- Hheadereq. *)subst. - eapply match_codestate_intro; eauto. - - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_FP; auto. - - (* GPR11 does not contain parent *) - + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. - intros [rs3 [S [T U]]]. - - exploit exec_straight_trans. - eapply P. - eapply S. - intros EXES. - - eapply exec_straight_body in EXES. - 2: simpl. 2: erewrite code_to_basics_id; eauto. - destruct EXES as (l & ll & BTC & CTB & EXECB). - exists rs3, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app2; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. - eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs2#FP <- (rs3#FP)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_FP; auto. - - (* MBop *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_operation tge sp op (map ms args) m' = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. - eapply preg_vals; eauto. - 2: eexact H0. - all: eauto. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - apply agree_set_undef_mreg with rs1; auto. - apply Val.lessdef_trans with v'; auto. - simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_FP; auto. -Local Transparent destroyed_by_op. - destruct op; simpl; auto; congruence. - - (* MBload *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. - - - (* MBstore *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_undef_regs; eauto with asmgen. - simpl; congruence. -Qed. - -Lemma exec_body_trans: - forall l l' rs0 m0 rs1 m1 rs2 m2, - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_body tge l' rs1 m1 = Next rs2 m2 -> - exec_body tge (l++l') rs0 m0 = Next rs2 m2. -Proof. - induction l. - - simpl. congruence. - - intros until m2. intros EXEB1 EXEB2. - inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. - simpl. rewrite EBI. eapply IHl; eauto. -Qed. - -Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. - -Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. -Next Obligation. - destruct tbb. simpl. auto. -Qed. - -Inductive exec_header: codestate -> codestate -> Prop := - | exec_header_cons: forall cs1, - exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) - cur := cur cs1 |}. - -Lemma step_simu_header: - forall bb s fb sp c ms m rs1 m1 cs1, -(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists cs1', - exec_header cs1 cs1' - /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). -Proof. - intros until cs1. intros Hpstate MCS. - eexists. split; eauto. - econstructor; eauto. - inv MCS. simpl in *. inv Hpstate. - econstructor; eauto. -Qed. - -Lemma step_matchasm_header: - forall fb cs1 cs1' s1, - match_asmstate fb cs1 s1 -> - exec_header cs1 cs1' -> - match_asmstate fb cs1' s1. -Proof. - intros until s1. intros MAS EXH. - inv MAS. inv EXH. - simpl. econstructor; eauto. -Qed. - -Lemma step_simu_body: - forall bb s fb sp c ms m rs1 m1 ms' cs1 m', - MB.header bb = nil -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 cs2 ep, - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} - /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). -Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. - inv BSTEP. - exists rs1, m1, cs1, (ep cs1). - inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). - econstructor; eauto. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. - exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. - intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). - simpl in *. - exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. - intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). - exists rs3, m3, cs3, ep. - repeat (split; simpl; auto). subst. simpl in *. auto. - rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. -Qed. - -(* Lemma exec_body_straight: - forall l rs0 m0 rs1 m1, - l <> nil -> - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_straight tge l rs0 m0 nil rs1 m1. -Proof. - induction l as [|i1 l]. - intros. contradict H; auto. - destruct l as [|i2 l]. - - intros until m1. intros _ EXEB. simpl in EXEB. - destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - inv EXEB. econstructor; eauto. - - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. - destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. - econstructor; eauto. eapply IHl; eauto. discriminate. -Qed. *) - -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma exec_body_control: - forall b rs1 m1 rs2 m2 rs3 m3 fn, - exec_body tge (body b) rs1 m1 = Next rs2 m2 -> - exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel tge fn b rs1 m1 rs3 m3. -Proof. - intros until fn. intros EXEB EXECTL. - econstructor; eauto. inv EXECTL. - unfold exec_bblock. rewrite EXEB. auto. -Qed. - -Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. - -Lemma mbsize_eqz: - forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. - remember (length _) as a. remember (length_opt _) as b. - assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. - inv H0. inv H1. destruct bdy; destruct ex; auto. - all: try discriminate. -Qed. - -Lemma mbsize_neqz: - forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. - destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). - contradict H. unfold mbsize. simpl. auto. -Qed. - -(* Alternative form of step_simulation_bblock, easier to prove *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, - bb' = mb_remove_header bb -> - body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> - bb'' = mb_remove_body bb' -> - (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. -Proof. - intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. - destruct (mbsize bb) eqn:SIZE. - - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. - inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - monadInv H2. simpl in *. inv ESTEP. inv BSTEP. - eexists. split. eapply plus_one. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - assert (x = tf) by congruence. subst x. - eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. - unfold exec_bblock. simpl. eauto. - econstructor. eauto. eauto. eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - intros. discriminate. - - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } - intros Hnotempty. - - (* initial setting *) - exploit match_state_codestate. - 2: eapply Hnotempty. - all: eauto. - intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - - (* step_simu_header part *) - assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } - destruct H as (rs1 & m1 & Hpstate2). subst. - assert (f = fb). { inv MCS. auto. } subst fb. - exploit step_simu_header. - 2: eapply MCS. - all: eauto. - intros (cs1' & EXEH & MCS2). - - (* step_simu_body part *) -(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } - rewrite H in BSTEP. clear H. *) - assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } - exploit step_simu_body. - 3: eapply BSTEP. - 4: eapply MCS2. - all: eauto. rewrite Hpstate'. eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). - - (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). - { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } - destruct H as (tf & FIND'). - assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). - { inv MAS. simpl in *. eauto. } - destruct H as (tex & Hpbody2 & Hpctl). - inv EXEH. simpl in *. - subst. exploit step_simu_control. - 9: eapply MCS'. all: simpl. - 10: eapply ESTEP. - all: simpl; eauto. - rewrite Hpbody2. rewrite Hpctl. - { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. - erewrite exec_body_pc; eauto. } - intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). - - (* bringing the pieces together *) - exploit exec_body_trans. - eapply EXEB. - eauto. - intros EXEB2. - exploit exec_body_control; eauto. - rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. - rewrite Hexit. rewrite Hpctl. eauto. - intros EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr f ofs). - { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } - destruct H0 as (ofs & Hrs1pc). - eapply exec_step_internal; eauto. - - (* proving the initial find_bblock *) - rewrite Hpstate2 in MAS. inv MAS. simpl in *. - assert (f1 = f0) by congruence. subst f0. - rewrite PCeq in Hrs1pc. inv Hrs1pc. - exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. - inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. - eapply find_bblock_tail; eauto. -Qed. - -Lemma step_simulation_bblock: - forall sf f sp bb ms m ms' m' S2 c, - body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. -Proof. - intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. - eapply step_simulation_bblock'; eauto. - all: destruct bb as [hd bdy ex]; simpl in *; eauto. - inv ESTEP. - - econstructor. inv H; try (econstructor; eauto; fail). - - econstructor. -Qed. - -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. - -Definition split (c: MB.code) := - match c with - | nil => nil - | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} - :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c - end. - -Lemma cons_ok_eq3 {A: Type} : - forall (x:A) y z x' y' z', - x = x' -> y = y' -> z = z' -> - OK (x::y::z) = OK (x'::y'::z'). -Proof. - intros. subst. auto. -Qed. - -Lemma transl_blocks_split_builtin: - forall bb c ep f ef args res, - MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> - transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. -Proof. - intros until res. intros Hexit Hbody. simpl split. - unfold transl_blocks. fold transl_blocks. unfold transl_block. - simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. - remember (transl_blocks _ _ _) as tlbs. - destruct tbc; destruct tbi; destruct tlbs. - all: try simpl; auto. - - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. - unfold gen_bblocks. simpl. destruct l. - + exploit transl_basic_code_nonil; eauto. intro. destruct H. - + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. -Qed. - -Lemma transl_code_at_pc_split_builtin: - forall rs f f0 bb c ep tf tc ef args res, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> - transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. -Proof. - intros until res. intros Hbody Hexit AT. inv AT. - econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. -Qed. - -Theorem match_states_split_builtin: - forall sf f sp bb c rs m ef args res S1, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. -Proof. - intros until S1. intros Hbody Hexit MS. - inv MS. - econstructor; eauto. - eapply transl_code_at_pc_split_builtin; eauto. -Qed. - -Lemma step_simulation_builtin: - forall ef args res bb sf f sp c ms m t S2, - MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. -Proof. - intros until S2. intros Hbody Hexit ESTEP S1' MS. - inv MS. inv AT. monadInv H2. monadInv EQ. - rewrite Hbody in EQ0. monadInv EQ0. - rewrite Hexit in EQ. monadInv EQ. - rewrite Hexit in ESTEP. inv ESTEP. inv H4. - - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H1); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - econstructor; split. apply plus_one. - simpl in H3. - eapply exec_step_builtin. eauto. eauto. - eapply find_bblock_tail; eauto. - simpl. eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock, incrPC. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextblock. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - apply Pregmap.gso; auto with asmgen. - congruence. -Qed. - -Lemma next_sep: - forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - congruence. -Qed. - -Theorem step_simulation: - forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros. - -- (* bblock *) - left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. - all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; - try (rewrite MBE; try discriminate); eauto). - + (* MBbuiltin *) - destruct (MB.body bb) eqn:MBB. - * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. - * eapply match_states_split_builtin in MS; eauto. - 2: rewrite MBB; discriminate. - simpl split in MS. - rewrite <- MBB in H. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. - assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } - rewrite H1 in H. subst. - exploit step_simulation_bblock. eapply H. - discriminate. - simpl. constructor. - eauto. - intros (S2' & PLUS1 & MS'). - rewrite MBE in MS'. - assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) - (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) - rs' m') t s'). - { inv H0. inv H3. econstructor. econstructor; eauto. } - exploit step_simulation_builtin. - 4: eapply MS'. - all: simpl; eauto. - intros (S3' & PLUS'' & MS''). - exists S3'. split; eauto. - eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. - + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - -- (* internal function *) - inv MS. - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. - unfold Mach.store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - (* Execution of function prologue *) - monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) - set (tfbody := make_prologue f x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). - exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. - intros (rs' & U' & V'). -(* exploit (exec_straight_through_singleinst); eauto. - intro W'. remember (nextblock _ rs') as rs''. *) - exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). - rewrite chunk_of_Tptr in P. - assert (rs' GPRA = rs0 RA). { apply V'. } - assert (rs' SP = rs2 SP). { apply V'; discriminate. } - rewrite H4. rewrite H3. - (* change (rs' GPRA) with (rs0 RA). *) - rewrite ATLR. - change (rs2 SP) with sp. eexact P. - intros (rs3 & U & V). -(* exploit (exec_straight_through_singleinst); eauto. - intro W. *) - assert (EXEC_PROLOGUE: exists rs3', - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3' - /\ forall r, r <> PC -> rs3' r = rs3 r). - { eexists. split. - - change (fn_blocks tf) with tfbody; unfold tfbody. - econstructor; eauto. unfold exec_bblock. simpl exec_body. - rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. - Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. - rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. - simpl. apply next_sep; eauto. reflexivity. - - intros. destruct V' as (V'' & V'). destruct r. - + Simpl. - destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } - + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. - + contradiction. - } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3' m3'); split. - eapply exec_straight_steps_1; eauto. - simpl fn_blocks. simpl fn_blocks in g. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. - simpl; intros; Simpl. - unfold sp; congruence. - - intros. - assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. - assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - (* rewrite H8; auto. *) - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - intros. rewrite Heqrs3'. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. discriminate. -- (* external function *) - inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. - apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, MB.initial_state prog st1 -> - exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Mach.Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - Asmblockgenproof0.return_address_offset. - -Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - - apply senv_preserved. - - eexact transf_initial_states. - - eexact transf_final_states. - - exact step_simulation. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +(** * Properties of control flow *) + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +(** The following lemmas show that the translation from Mach to Asm + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ Asm instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- Asm instr seq tail + translation +>> + The proof demands many boring lemmas showing that Asm constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma in_dec_transl: + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + +Lemma transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated Asm code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +(* NB: the hypothesis in comment on [b] is not needed in the proof ! +*) +Lemma return_address_exists: + forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. +(* rewrite transl_code'_transl_code in EQ0. *) + exists x; exists true; split; auto. (* unfold fn_code. *) + repeat constructor. + - exact transf_function_no_overflow. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using simulation diagrams + of the following form. +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + The invariant is the [match_states] predicate below, which includes: +- The Asm code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and Asm register values agree. +*) + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the Asm side. Actually, all Mach transitions + correspond to at least one Asm transition, except the + transition from [Machsem.Returnstate] to [Machsem.State]. + So, the following integer measure will suffice to rule out + the unwanted behaviour. *) + + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := + Codestate { pstate: state; + pheader: list label; + pbody1: list basic; + pbody2: list basic; + pctl: option control; + ep: bool; + rem: list AB.bblock; + cur: bblock }. + +(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) + +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) +(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; + pbody2 := (extract_basic tbi); + pctl := extract_ctl tbi; + ep := ep; + rem := tc; + cur := tbb + |} +. + +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) +(* (HDROK: header tbb = lhd) *) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; + ep := ep; + rem := tc; + cur := tbb |} + (Asmvliw.State rs m) +. + +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. + intros until ep0. intros TLBS Hbuiltin. + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs + /\ cur cs = tbb /\ rem cs = tc + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +(* - subst. Simpl. *) +Qed. + +Lemma cons3_app {A: Type}: + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +(* Lemma goto_label_inv: + forall fn tbb l rs m b ofs, + rs PC = Vptr b ofs -> + goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. +Proof. + intros. + unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. + exploreInst; auto. + unfold nextblock. rewrite Pregmap.gss. + +Qed. + + +Lemma exec_control_goto_label_inv: + exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> + exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. +Proof. +Qed. *) + +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = tbb -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. + inv Hpstate. + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + (* inv AT. monadInv H4. *) + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. +(* - destruct g. all: rewrite INV; Simpl; auto. *) + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. +(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) + intros (TLB & TLBS). + *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. +(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + +Lemma step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } +(* rewrite <- Hheadereq. *) subst. simpl in Hheadereq. + + eapply match_codestate_intro; eauto. + { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. + discriminate. apply preg_of_not_FP; assumption. reflexivity. + + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + (* Opaque loadind. *) +(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep0 eqn:EPeq. + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + (* rewrite <- Hheadereq. *)subst. + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + + (* GPR11 does not contain parent *) + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. + apply preg_of_not_FP; assumption. reflexivity. + + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_undef_regs; eauto with asmgen. + intro Hep. simpl in Hep. + subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; + (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) + cur := cur cs1 |}. + +Lemma step_simu_header: + forall bb s fb sp c ms m rs1 m1 cs1, +(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + +Lemma step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. + exists rs1, m1, cs1, (ep cs1). + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +(* Lemma exec_body_straight: + forall l rs0 m0 rs1 m1, + l <> nil -> + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_straight tge l rs0 m0 nil rs1 m1. +Proof. + induction l as [|i1 l]. + intros. contradict H; auto. + destruct l as [|i2 l]. + - intros until m1. intros _ EXEB. simpl in EXEB. + destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + inv EXEB. econstructor; eauto. + - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. + destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. + econstructor; eauto. eapply IHl; eauto. discriminate. +Qed. *) + +Lemma exec_body_pc: + forall l rs1 m1 rs2 m2, + exec_body tge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + +(* Alternative form of step_simulation_bblock, easier to prove *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) +(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } + rewrite H in BSTEP. clear H. *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. + eapply find_bblock_tail; eauto. +Qed. + +Lemma step_simulation_bblock: + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + +Lemma step_simulation_builtin: + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) + monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). +(* exploit (exec_straight_through_singleinst); eauto. + intro W'. remember (nextblock _ rs') as rs''. *) + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + rewrite chunk_of_Tptr in P. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + (* change (rs' GPRA) with (rs0 RA). *) + rewrite ATLR. + change (rs2 SP) with sp. eexact P. + intros (rs3 & U & V). +(* exploit (exec_straight_through_singleinst); eauto. + intro W. *) + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + (* rewrite H8; auto. *) + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 263a8d93cfabcec746c06d4abdcd06a0e8ec6d14 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 11 Oct 2019 11:54:27 +0200 Subject: Converting mppa_k1c/*.v files to Unix format --- mppa_k1c/Asm.v | 1506 ++++++++++++++++++++++++++--------------------------- mppa_k1c/Asmaux.v | 2 +- 2 files changed, 754 insertions(+), 754 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index f09aa99c..e27ff40c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +1,753 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) - -(** * Abstract syntax for K1c textual assembly language. - - Each emittable instruction is defined here. ';;' is also defined as an instruction. - The goal of this representation is to stay compatible with the rest of the generic backend of CompCert - We define [unfold : list bblock -> list instruction] - An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] - [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Asmvliw. -Require Import Linking. -Require Import Errors. - -(** Definitions for OCaml code *) -Definition label := positive. -Definition preg := preg. - -Inductive addressing : Type := - | AOff (ofs: offset) - | AReg (ro: ireg) - | ARegXS (ro: ireg) -. - -(** Syntax *) -Inductive instruction : Type := - (** pseudo instructions *) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Plabel (lbl: label) (**r define a code label *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Psemi (**r semi colon separating bundles *) - | Pnop (**r instruction that does nothing *) - - (** Control flow instructions *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (rs: ireg) (**r function call on register *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (rs: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) - | Pjumptable (r: ireg) (labels: list label) - - (* For builtins *) - | Ploopdo (count: ireg) (loopend: label) - | Pgetn (n: int) (dst: ireg) - | Psetn (n: int) (src: ireg) - | Pwfxl (n: int) (src: ireg) - | Pwfxm (n: int) (src: ireg) - | Pldu (dst: ireg) (addr: ireg) - | Plbzu (dst: ireg) (addr: ireg) - | Plhzu (dst: ireg) (addr: ireg) - | Plwzu (dst: ireg) (addr: ireg) - | Pawait - | Psleep - | Pstop - | Pbarrier - | Pfence - | Pdinval - | Pdinvall (addr: ireg) - | Pdtouchl (addr: ireg) - | Piinval - | Piinvals (addr: ireg) - | Pitouchl (addr: ireg) - | Pdzerol (addr: ireg) -(*| Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) - | Palclrd (dst: ireg) (addr: ireg) - | Palclrw (dst: ireg) (addr: ireg) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - - (** Loads **) - | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) - | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) - | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) - - (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) - | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) - - | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - - (** Arith RR *) - | Pmv (rd rs: ireg) (**r register move *) - | Pnegw (rd rs: ireg) (**r negate word *) - | Pnegl (rd rs: ireg) (**r negate long *) - | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) - | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) - - | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - - | Pfabsd (rd rs: ireg) (**r float absolute double *) - | Pfabsw (rd rs: ireg) (**r float absolute word *) - | Pfnegd (rd rs: ireg) (**r float negate double *) - | Pfnegw (rd rs: ireg) (**r float negate word *) - | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) - | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) - | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) - | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) - | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) - | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) - | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) - | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) - - (** Arith RI32 *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - - (** Arith RI64 *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - - (** Arith RF32 *) - | Pmakefs (rd: ireg) (imm: float32) - - (** Arith RF64 *) - | Pmakef (rd: ireg) (imm: float) - - (** Arith RRR *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) - | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) - - | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Pmulw (rd rs1 rs2: ireg) (**r mul word *) - | Pandw (rd rs1 rs2: ireg) (**r and word *) - | Pnandw (rd rs1 rs2: ireg) (**r nand word *) - | Porw (rd rs1 rs2: ireg) (**r or word *) - | Pnorw (rd rs1 rs2: ireg) (**r nor word *) - | Pxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pandnw (rd rs1 rs2: ireg) (**r andn word *) - | Pornw (rd rs1 rs2: ireg) (**r orn word *) - | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) - | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) - | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) - | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) - | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) - | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) - - | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) - | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) - | Pandl (rd rs1 rs2: ireg) (**r and long *) - | Pnandl (rd rs1 rs2: ireg) (**r nand long *) - | Porl (rd rs1 rs2: ireg) (**r or long *) - | Pnorl (rd rs1 rs2: ireg) (**r nor long *) - | Pxorl (rd rs1 rs2: ireg) (**r xor long *) - | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) - | Pandnl (rd rs1 rs2: ireg) (**r andn long *) - | Pornl (rd rs1 rs2: ireg) (**r orn long *) - | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) - | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) - | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) - | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) - - | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) - | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) - | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) - | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) - | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) - | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) - | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) - | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) - | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) - | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - | Pfinvw (rd rs1: ireg) (**r Float invert word *) - - (** Arith RRI32 *) - | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) - - | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) - | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) - | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) - | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) - | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) - | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) - | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) - | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) - | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) - | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) - | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) - | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - - (** Arith RRI64 *) - | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) - | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) - | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) - | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) - | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) - | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) - | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) - | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) - | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) - | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) -. - -(** Correspondance between Asmblock and Asm *) - -Definition control_to_instruction (c: control) := - match c with - | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmvliw.Pret => Pret - | PCtlFlow (Asmvliw.Pcall l) => Pcall l - | PCtlFlow (Asmvliw.Picall r) => Picall r - | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l - | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l - | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l - | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label - end. - -Definition basic_to_instruction (b: basic) := - match b with - (** Special basics *) - | Asmvliw.Pget rd rs => Pget rd rs - | Asmvliw.Pset rd rs => Pset rd rs - | Asmvliw.Pnop => Pnop - | Asmvliw.Pallocframe sz pos => Pallocframe sz pos - | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos - - (** PArith basics *) - (* R *) - | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs - - (* RR *) - | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs - | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs - | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start - | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start - | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start - | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start - | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs - | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs - - (* RI32 *) - | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm - - (* RI64 *) - | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm - - (* RF32 *) - | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm - - (* RF64 *) - | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm - - (* RRR *) - | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 - | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 - | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 - - | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 - | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 - - (* RRI32 *) - | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm - | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm - | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm - | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm - | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm - - (* RRI64 *) - | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm - | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm - | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm - - (** ARRR *) - | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 - - (** ARR *) - | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start - | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start - - (** ARRI32 *) - | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm - - (** ARRI64 *) - | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm - (** Load *) - | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) - | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) - | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) - - | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) - | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - - | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) - | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) - | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) - | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) - | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) - | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) - - | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) - | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) - - (** Store *) - | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) - - | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) - - | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) - | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) - end. - -Section RELSEM. - -Definition code := list instruction. - -Fixpoint unfold_label (ll: list label) := - match ll with - | nil => nil - | l :: ll => Plabel l :: unfold_label ll - end. - -Fixpoint unfold_body (lb: list basic) := - match lb with - | nil => nil - | b :: lb => basic_to_instruction b :: unfold_body lb - end. - -Definition unfold_exit (oc: option control) := - match oc with - | None => nil - | Some c => control_to_instruction c :: nil - end. - -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ - (match (body b), (exit b) with - | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => - unfold_body bo - | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil - end). - -Fixpoint unfold (lb: bblocks) := - match lb with - | nil => nil - | b :: lb => (unfold_bblock b) ++ unfold lb - end. - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; - correct: unfold fn_blocks = fn_code }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). - -Definition fundef_proj (fu: fundef) : Asmvliw.fundef := - match fu with - | Internal f => Internal (function_proj f) - | External ef => External ef - end. - -Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := - match gd with - | Gfun f => Gfun (fundef_proj f) - | Gvar gu => Gvar gu - end. - -Program Definition genv_trans (ge: genv) : Asmvliw.genv := - {| Genv.genv_public := Genv.genv_public ge; - Genv.genv_symb := Genv.genv_symb ge; - Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); - Genv.genv_next := Genv.genv_next ge |}. -Next Obligation. - destruct ge. simpl in *. eauto. -Qed. Next Obligation. - destruct ge; simpl in *. - rewrite PTree.gmap1 in H. - destruct (genv_defs ! b) eqn:GEN. - - eauto. - - discriminate. -Qed. Next Obligation. - destruct ge; simpl in *. - eauto. -Qed. - -Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmvliw.fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l - end. - -Definition program_proj (p: program) : Asmvliw.program := - {| prog_defs := prog_defs_proj (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -End RELSEM. - -Definition semantics (p: program) := Asmvliw.semantics (program_proj p). - -(** Determinacy of the [Asm] semantics. *) - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. - intros. apply semantics_determinate. -Qed. - -(** transf_program *) - -Program Definition transf_function (f: Asmvliw.function) : function := - {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; - fn_code := unfold (Asmvliw.fn_blocks f) |}. - -Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. -Proof. - intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. -Qed. - -Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. - -Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. -Proof. - intros f. destruct f as [f|e]; simpl; auto. - rewrite transf_function_proj. auto. -Qed. - -Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. - -Definition match_prog (p: Asmvliw.program) (tp: program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - -Section PRESERVATION. - -Variable prog: Asmvliw.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Definition match_states (s1 s2: state) := s1 = s2. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Theorem transf_program_correct: - forward_simulation (Asmvliw.semantics prog) (semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. - subst. unfold semantics. rewrite transf_program_proj. - - eapply forward_simulation_step with (match_states := match_states); simpl; auto. - - intros. exists s1. split; auto. congruence. - - intros. inv H. auto. - - intros. exists s1'. inv H0. split; auto. congruence. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs) + | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs) + | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro) + | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro) + | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro) + | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro) + | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro) + | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro) + | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro) + | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro) + | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro) + | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro) + + | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro) + | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 94b39f4e..891d1068 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -2,4 +2,4 @@ Require Import Asm. Require Import AST. (** Constant only needed by Asmexpandaux.ml *) -Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. -- cgit From 6d4ec0d398dcc9ec766c3f55ba4edbae63fb6a2f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 15:51:44 +0200 Subject: More elaborate comments + rewriting for easier to understand Asmblockgenproof.v --- mppa_k1c/Asmblockgenproof.v | 234 +++++++++++++++++--------------------------- 1 file changed, 89 insertions(+), 145 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index ad4d2932..834e11e1 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -47,7 +47,6 @@ Lemma senv_preserved: Senv.equiv ge tge. Proof (Genv.senv_match TRANSF). - Lemma functions_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> @@ -65,8 +64,6 @@ Proof. monadInv B. rewrite H0 in EQ; inv EQ; auto. Qed. -(** * Properties of control flow *) - Lemma transf_function_no_overflow: forall f tf, transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. @@ -75,23 +72,7 @@ Proof. omega. Qed. -(** The following lemmas show that the translation from Mach to Asm - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ Asm instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- Asm instr seq tail - translation ->> - The proof demands many boring lemmas showing that Asm constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) Lemma gen_bblocks_label: forall hd bdy ex tbb tc, @@ -113,7 +94,7 @@ Proof. all: inv GENB; simpl; auto. Qed. -Lemma in_dec_transl: +Remark in_dec_transl: forall lbl hd, (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). Proof. @@ -226,7 +207,7 @@ Proof. rewrite H. auto. Qed. -Lemma transl_find_label: +Theorem transl_find_label: forall lbl f tf, transf_function f = OK tf -> match MB.find_label lbl f.(MB.fn_code) with @@ -241,8 +222,8 @@ Qed. End TRANSL_LABEL. -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated Asm code. *) +(** A valid branch in a piece of Machblock code translates to a valid ``go to'' + transition in the generated Asmblock code. *) Lemma find_label_goto_label: forall f tf lbl rs m c' b ofs, @@ -270,48 +251,47 @@ Qed. (** Existence of return addresses *) -(* NB: the hypothesis in comment on [b] is not needed in the proof ! -*) Lemma return_address_exists: - forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) -> + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> exists ra, return_address_offset f c ra. Proof. intros. eapply Asmblockgenproof0.return_address_exists; eauto. - intros. monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. -(* rewrite transl_code'_transl_code in EQ0. *) - exists x; exists true; split; auto. (* unfold fn_code. *) + exists x; exists true; split; auto. repeat constructor. - - exact transf_function_no_overflow. +- exact transf_function_no_overflow. Qed. (** * Proof of semantic preservation *) -(** Semantic preservation is proved using simulation diagrams +(** Semantic preservation is proved using a complex simulation diagram of the following form. << - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' + MB.step + ----------------------------------------> + header body exit + st1 -----> st2 -----> st3 ------------------> st4 + | | | | + | (A) | (B) | (C) | + match_codestate | | | | + | header | body1 | body2 | match_states + cs1 -----> cs2 -----> cs3 ------> cs4 | + | / \ exit | + match_asmstate | --------------- --->--- | + | / match_asmstate \ | + st'1 ---------------------------------------> st'2 + AB.step * >> - The invariant is the [match_states] predicate below, which includes: -- The Asm code pointed by the PC register is the translation of - the current Mach code sequence. -- Mach register values and Asm register values agree. -*) - -(** We need to show that, in the simulation diagram, we cannot - take infinitely many Mach transitions that correspond to zero - transitions on the Asm side. Actually, all Mach transitions - correspond to at least one Asm transition, except the - transition from [Machsem.Returnstate] to [Machsem.State]. - So, the following integer measure will suffice to rule out - the unwanted behaviour. *) + The invariant between each MB.step/AB.step is the [match_states] predicate below. + However, we also need to introduce an intermediary state [Codestate] which allows + us to reason on a finer grain, executing header, body and exit separately. + This [Codestate] consists in a state like [Asmblock.State], except that the + code is directly stored in the state, much like [Machblock.State]. It also features + additional useful elements to keep track of while executing a bblock. +*) Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. Proof. @@ -349,17 +329,18 @@ Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := (Asmvliw.State rs m'). Record codestate := - Codestate { pstate: state; + Codestate { pstate: state; (**r projection to Asmblock.state *) pheader: list label; - pbody1: list basic; - pbody2: list basic; - pctl: option control; - ep: bool; - rem: list AB.bblock; - cur: bblock }. - -(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *) - + pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) + pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) + pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) + ep: bool; (**r reflects the [ep] variable used in the translation *) + rem: list AB.bblock; (**r remaining bblocks to execute *) + cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) + }. + +(* The part that deals with Machblock <-> Codestate agreement + * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) Inductive match_codestate fb: Machblock.state -> codestate -> Prop := | match_codestate_intro: forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi @@ -369,7 +350,6 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) (TIC: transl_instr_control f (MB.exit bb) = OK tbi) (TBLS: transl_blocks f c false = OK tc) -(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *) (AG: agree ms sp rs0) (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) , @@ -377,7 +357,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := {| pstate := (Asmvliw.State rs0 m0); pheader := (MB.header bb); pbody1 := tbc; - pbody2 := (extract_basic tbi); + pbody2 := extract_basic tbi; pctl := extract_ctl tbi; ep := ep; rem := tc; @@ -385,6 +365,7 @@ Inductive match_codestate fb: Machblock.state -> codestate -> Prop := |} . +(* The part ensuring that the code in Codestate actually resides at [rs PC] *) Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := | match_asmstate_some: forall rs f tf tc m tbb ofs ep tbdy tex lhd @@ -392,7 +373,6 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (TRANSF: transf_function f = OK tf) (PCeq: rs PC = Vptr fb ofs) (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) -(* (HDROK: header tbb = lhd) *) , match_asmstate fb {| pstate := (Asmvliw.State rs m); @@ -406,6 +386,7 @@ Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := (Asmvliw.State rs m) . +(* Useful for dealing with the many cases in some proofs *) Ltac exploreInst := repeat match goal with | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var @@ -417,6 +398,8 @@ Ltac exploreInst := | [ H : Error _ = OK _ |- _ ] => inversion H end. +(** Some translation properties *) + Lemma transl_blocks_nonil: forall f bb c tc ep, transl_blocks f (bb::c) ep = OK tc -> @@ -584,6 +567,9 @@ Proof. * unfold transl_comp_notfloat32. exploreInst; try discriminate. Qed. +(* Proving that one can decompose a [match_state] relation into a [match_codestate] + and a [match_asmstate], along with some helpful properties tying both relations together *) + Theorem match_state_codestate: forall mbs abs s fb sp bb c ms m, (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -624,7 +610,7 @@ Definition mb_remove_body (bb: MB.bblock) := Lemma exec_straight_pnil: forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 -> + exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> exec_straight tge c rs1 m1 nil rs2 m2. Proof. intros. eapply exec_straight_trans. eapply H. econstructor; eauto. @@ -656,10 +642,9 @@ Lemma nextblock_preserves: Proof. intros. destruct r; try discriminate. subst. Simpl. -(* - subst. Simpl. *) Qed. -Lemma cons3_app {A: Type}: +Remark cons3_app {A: Type}: forall a b c (l: list A), a :: b :: c :: l = (a :: b :: c :: nil) ++ l. Proof. @@ -693,27 +678,11 @@ Proof. induction lb; intros; simpl; congruence. Qed. -(* Lemma goto_label_inv: - forall fn tbb l rs m b ofs, - rs PC = Vptr b ofs -> - goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m. -Proof. - intros. - unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H. - exploreInst; auto. - unfold nextblock. rewrite Pregmap.gss. - -Qed. - - -Lemma exec_control_goto_label_inv: - exec_control tge fn (Some ctl) rs m = goto_label fn l rs m -> - exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m. -Proof. -Qed. *) - +(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are + unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by + yourself the steps *) Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2, + forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, MB.body bb' = nil -> (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> Genv.find_funct_ptr tge fb = Some (Internal fn) -> @@ -722,7 +691,7 @@ Theorem step_simu_control: cur cs2 = tbb -> match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> (exists rs3 m3 rs4 m4, exec_body tge tbdy2 rs2 m2 = Next rs3 m3 /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 @@ -834,7 +803,6 @@ Proof. assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. remember (nextblock tbb rs2) as rs2'. - (* inv AT. monadInv H4. *) exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. assert (tf = fn) by congruence. subst tf. exploit find_label_goto_label. @@ -853,7 +821,6 @@ Proof. assert (forall r : preg, r <> PC -> rs' r = rs2 r). { intros. destruct r. - destruct g. all: rewrite INV; Simpl; auto. -(* - destruct g. all: rewrite INV; Simpl; auto. *) - rewrite INV; Simpl; auto. - contradiction. } eauto with asmgen. @@ -932,7 +899,7 @@ Proof. intros [tc' [rs' [A [B C]]]]. exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - + repeat eexists. rewrite H6. simpl extract_basic. simpl. eauto. rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. @@ -955,7 +922,7 @@ Proof. simpl. eauto. intros EXEB. assert (f1 = f) by congruence. subst f1. - + repeat eexists. rewrite H6. simpl extract_basic. eauto. rewrite H7. simpl extract_ctl. simpl. reflexivity. @@ -963,10 +930,7 @@ Proof. unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. -(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *) - intros (TLB & TLBS). - *) destruct bb' as [hd' bdy' ex']; simpl in *. subst. -(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *) + destruct bb' as [hd' bdy' ex']; simpl in *. subst. monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. simpl. repeat eexists. econstructor. 4: instantiate (3 := false). all:eauto. @@ -1023,7 +987,8 @@ Proof. all: eauto. Qed. -Lemma step_simu_basic: +(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) +Theorem step_simu_basic: forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> @@ -1058,7 +1023,7 @@ Proof. eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } -(* rewrite <- Hheadereq. *) subst. simpl in Hheadereq. + subst. simpl in Hheadereq. eapply match_codestate_intro; eauto. { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } @@ -1084,8 +1049,7 @@ Proof. repeat (split; auto). eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + subst. eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. eapply agree_undef_regs; eauto with asmgen. @@ -1101,10 +1065,9 @@ Proof. exploit Mem.loadv_extends. eauto. eexact H1. auto. intros [v' [C D]]. - (* Opaque loadind. *) -(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *) monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. destruct ep0 eqn:EPeq. + (* RTMP contains parent *) + exploit loadind_correct. eexact EQ1. instantiate (2 := rs1). rewrite DXP; eauto. @@ -1119,14 +1082,14 @@ Proof. { eapply basics_to_code_app; eauto. } remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - (* rewrite <- Hheadereq. *)subst. + subst. eapply match_codestate_intro; eauto. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. simpl; intros. rewrite R; auto with asmgen. apply preg_of_not_FP; auto. - (* GPR11 does not contain parent *) + (* RTMP does not contain parent *) + rewrite chunk_of_Tptr in A. exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. @@ -1157,7 +1120,7 @@ Proof. apply preg_of_not_FP; auto. - (* MBop *) simpl in EQ0. rewrite Hheader in DXP. - + assert (eval_operation tge sp op (map ms args) m' = Some v). rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. exploit eval_operation_lessdef. @@ -1175,8 +1138,7 @@ Proof. repeat (split; auto). eapply basics_to_code_app; eauto. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + subst. eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. apply agree_set_undef_mreg with rs1; auto. apply Val.lessdef_trans with v'; auto. @@ -1265,12 +1227,11 @@ Inductive exec_header: codestate -> codestate -> Prop := | exec_header_cons: forall cs1, exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *) cur := cur cs1 |}. -Lemma step_simu_header: +(* Theorem (A) in the diagram, the easiest of all *) +Theorem step_simu_header: forall bb s fb sp c ms m rs1 m1 cs1, -(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *) pstate cs1 = (State rs1 m1) -> match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> (exists cs1', @@ -1295,7 +1256,8 @@ Proof. simpl. econstructor; eauto. Qed. -Lemma step_simu_body: +(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) +Theorem step_simu_body: forall bb s fb sp c ms m rs1 m1 ms' cs1 m', MB.header bb = nil -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1326,23 +1288,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -(* Lemma exec_body_straight: - forall l rs0 m0 rs1 m1, - l <> nil -> - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_straight tge l rs0 m0 nil rs1 m1. -Proof. - induction l as [|i1 l]. - intros. contradict H; auto. - destruct l as [|i2 l]. - - intros until m1. intros _ EXEB. simpl in EXEB. - destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - inv EXEB. econstructor; eauto. - - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl. - destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate. - econstructor; eauto. eapply IHl; eauto. discriminate. -Qed. *) - Lemma exec_body_pc: forall l rs1 m1 rs2 m2, exec_body tge l rs1 m1 = Next rs2 m2 -> @@ -1387,7 +1332,8 @@ Proof. contradict H. unfold mbsize. simpl. auto. Qed. -(* Alternative form of step_simulation_bblock, easier to prove *) +(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) +(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) Lemma step_simulation_bblock': forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, bb' = mb_remove_header bb -> @@ -1436,8 +1382,6 @@ Proof. intros (cs1' & EXEH & MCS2). (* step_simu_body part *) -(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. } - rewrite H in BSTEP. clear H. *) assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } exploit step_simu_body. 3: eapply BSTEP. @@ -1487,7 +1431,7 @@ Proof. eapply find_bblock_tail; eauto. Qed. -Lemma step_simulation_bblock: +Theorem step_simulation_bblock: forall sf f sp bb ms m ms' m' S2 c, body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> @@ -1503,12 +1447,7 @@ Proof. - econstructor. Qed. -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. +(** Dealing now with the builtin case *) Definition split (c: MB.code) := match c with @@ -1564,7 +1503,7 @@ Proof. eapply transl_code_at_pc_split_builtin; eauto. Qed. -Lemma step_simulation_builtin: +Theorem step_simulation_builtin: forall ef args res bb sf f sp c ms m t S2, MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> @@ -1611,6 +1550,16 @@ Proof. congruence. Qed. +(* Measure to prove finite stuttering, see the other backends *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs + for the internal and external function cases *) Theorem step_simulation: forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1665,25 +1614,20 @@ Proof. exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. intros [m3' [P Q]]. (* Execution of function prologue *) - monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *) + monadInv EQ0. set (tfbody := make_prologue f x0) in *. set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. intros (rs' & U' & V'). -(* exploit (exec_straight_through_singleinst); eauto. - intro W'. remember (nextblock _ rs') as rs''. *) exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). rewrite chunk_of_Tptr in P. assert (rs' GPRA = rs0 RA). { apply V'. } assert (rs' SP = rs2 SP). { apply V'; discriminate. } rewrite H4. rewrite H3. - (* change (rs' GPRA) with (rs0 RA). *) rewrite ATLR. change (rs2 SP) with sp. eexact P. intros (rs3 & U & V). -(* exploit (exec_straight_through_singleinst); eauto. - intro W. *) assert (EXEC_PROLOGUE: exists rs3', exec_straight_blocks tge tf tf.(fn_blocks) rs0 m' @@ -1729,7 +1673,6 @@ Local Transparent destroyed_at_function_entry. rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - (* rewrite H8; auto. *) contradict H3; rewrite H3; unfold data_preg; auto. contradict H3; rewrite H3; unfold data_preg; auto. contradict H3; rewrite H3; unfold data_preg; auto. @@ -1737,6 +1680,7 @@ Local Transparent destroyed_at_function_entry. intros. rewrite Heqrs3'. rewrite V by auto with asmgen. assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } rewrite H4 by auto with asmgen. reflexivity. discriminate. + - (* external function *) inv MS. exploit functions_translated; eauto. -- cgit From 72378d9371bc5da342266bcf14231ab568e0f919 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 15 Oct 2019 16:01:30 +0200 Subject: Few minor other changes in proof --- mppa_k1c/Asmblockgenproof.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 834e11e1..bd2dc985 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1621,12 +1621,12 @@ Proof. exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. intros (rs' & U' & V'). exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). - rewrite chunk_of_Tptr in P. + { rewrite chunk_of_Tptr in P. assert (rs' GPRA = rs0 RA). { apply V'. } assert (rs' SP = rs2 SP). { apply V'; discriminate. } rewrite H4. rewrite H3. rewrite ATLR. - change (rs2 SP) with sp. eexact P. + change (rs2 SP) with sp. eexact P. } intros (rs3 & U & V). assert (EXEC_PROLOGUE: exists rs3', exec_straight_blocks tge tf @@ -1652,7 +1652,7 @@ Proof. } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). exploit exec_straight_steps_2; eauto using functions_transl. simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). + intros (ofs' & X & Y). left; exists (State rs3' m3'); split. eapply exec_straight_steps_1; eauto. simpl fn_blocks. simpl fn_blocks in g. omega. -- cgit From d4e2f7b715b21efe0d693415ab63dad5a22afa92 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 16 Oct 2019 18:34:30 +0200 Subject: eq_condition already existed --- mppa_k1c/Op.v | 6 ------ 1 file changed, 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index ce9a5dcd..f9a774e8 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -51,12 +51,6 @@ Inductive condition : Type := | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) -Definition condition_eq: forall (x y: condition), {x = y} + {x <> y}. -Proof. - generalize comparison_eq int_eq int64_eq. - decide equality. -Defined. - Inductive condition0 : Type := | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) -- cgit From e247f20f8fb530bb225ac04f2e1589beaffcb257 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 21 Oct 2019 18:11:33 +0200 Subject: Un espace en trop --- mppa_k1c/Asmblockgen.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index bbe24fec..abb24327 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1185,7 +1185,7 @@ Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := match lmb with | nil => OK nil - | mb :: lmb => + | mb :: lmb => do lb <- transl_block f mb (if Machblock.header mb then ep else false); do lb' <- transl_blocks f lmb false; OK (lb @@ lb') -- cgit From 8d1b23070baa3c2db69a066dfc097e08bb811eb3 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 15:35:47 +0100 Subject: removing Focus (deprecated) --- mppa_k1c/lib/Machblockgenproof.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index ab7fff74..8da610ad 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -719,13 +719,13 @@ Proof. exists nil; simpl; eexists. eapply Tr_add_label; eauto. - (*i=basic*) destruct i'. - Focus 10. exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. rewrite Heqti. eapply Tr_end_block; eauto. rewrite <-Heqti. eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. + simpl in H5; congruence. } all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - (*i=cfi*) destruct i; try(simpl in Heqti; congruence). -- cgit From 4c471a5a7852d02c368101205b34418c0f754b91 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 14 Nov 2019 16:04:03 +0100 Subject: fixing a potential inconsistency from unsafe_coerce Now, unsafe_coerce axioms are clearly consistent (for any interpretation of may-return monads). But, the extraction is still unsafe... --- mppa_k1c/Asmblockdeps.v | 10 ++++++++-- mppa_k1c/abstractbb/Impure/ImpConfig.v | 10 +++++----- 2 files changed, 13 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c4c1bbf1..8bc1112f 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1636,11 +1636,17 @@ Hint Resolve bblock_simu_test_correct: wlp. Import UnsafeImpure. -Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2). +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := + match unsafe_coerce (bblock_simu_test verb p1 p2) with + | Some b => b + | None => false + end. Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. Proof. - intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto. + unfold pure_bblock_simu_test. + destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. + intros; subst. eapply bblock_simu_test_correct; eauto. apply unsafe_coerce_not_really_correct; eauto. Qed. diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index 1bd93d4c..e49a4611 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -22,9 +22,9 @@ Module Type ImpureView. (* START COMMENT *) Module UnsafeImpure. - Parameter unsafe_coerce: forall {A}, t A -> A. + Parameter unsafe_coerce: forall {A}, t A -> option A. - Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x. + Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x. Extraction Inline unsafe_coerce. @@ -41,11 +41,11 @@ Module Impure: ImpureView. Module UnsafeImpure. - Definition unsafe_coerce {A} (x:t A) := x. + Definition unsafe_coerce {A} (x:t A) := Some x. - Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=x -> mayRet k x. + Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x. Proof. - unfold unsafe_coerce, mayRet; auto. + unfold unsafe_coerce, mayRet; congruence. Qed. End UnsafeImpure. -- cgit From 553714035fc08f9b145b89b3dd7c455f06e917df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 2 Dec 2019 21:39:20 +0100 Subject: finish merge --- mppa_k1c/Asmblockgen.v | 2 +- mppa_k1c/Asmblockgenproof.v | 29 +++++++++++++++++++---------- 2 files changed, 20 insertions(+), 11 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 5825fd04..50637723 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1116,7 +1116,7 @@ Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := | MBsetstack src ofs ty => before | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) | MBop op args res => before && negb (mreg_eq res MFP) - | MBload chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) | MBstore chunk addr args res => before end. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index cdbaf16a..b3e0ee23 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1203,14 +1203,18 @@ Local Transparent destroyed_by_op. exists rs2, m1, ll. eexists. eexists. split. instantiate (1 := x). eauto. repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + eapply basics_to_code_app; eauto. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. + simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. } { exploit transl_load_correct_notrap2; eauto. @@ -1226,10 +1230,15 @@ Local Transparent destroyed_by_op. remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. (* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl; congruence. + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. } - (* MBstore *) simpl in EQ0. rewrite Hheader in DXP. -- cgit From 98764278b804517f733982071da37769816a4833 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 3 Dec 2019 15:12:09 +0100 Subject: Converting Asm.v and Asmblockgenproof.v back to Unix format --- mppa_k1c/Asm.v | 1506 +++++++++---------- mppa_k1c/Asmblockgenproof.v | 3346 +++++++++++++++++++++---------------------- 2 files changed, 2426 insertions(+), 2426 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index e37176ef..189e0c76 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,753 +1,753 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) - -(** * Abstract syntax for K1c textual assembly language. - - Each emittable instruction is defined here. ';;' is also defined as an instruction. - The goal of this representation is to stay compatible with the rest of the generic backend of CompCert - We define [unfold : list bblock -> list instruction] - An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] - [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Asmvliw. -Require Import Linking. -Require Import Errors. - -(** Definitions for OCaml code *) -Definition label := positive. -Definition preg := preg. - -Inductive addressing : Type := - | AOff (ofs: offset) - | AReg (ro: ireg) - | ARegXS (ro: ireg) -. - -(** Syntax *) -Inductive instruction : Type := - (** pseudo instructions *) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Plabel (lbl: label) (**r define a code label *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Psemi (**r semi colon separating bundles *) - | Pnop (**r instruction that does nothing *) - - (** Control flow instructions *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (rs: ireg) (**r function call on register *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (rs: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) - | Pjumptable (r: ireg) (labels: list label) - - (* For builtins *) - | Ploopdo (count: ireg) (loopend: label) - | Pgetn (n: int) (dst: ireg) - | Psetn (n: int) (src: ireg) - | Pwfxl (n: int) (src: ireg) - | Pwfxm (n: int) (src: ireg) - | Pldu (dst: ireg) (addr: ireg) - | Plbzu (dst: ireg) (addr: ireg) - | Plhzu (dst: ireg) (addr: ireg) - | Plwzu (dst: ireg) (addr: ireg) - | Pawait - | Psleep - | Pstop - | Pbarrier - | Pfence - | Pdinval - | Pdinvall (addr: ireg) - | Pdtouchl (addr: ireg) - | Piinval - | Piinvals (addr: ireg) - | Pitouchl (addr: ireg) - | Pdzerol (addr: ireg) -(*| Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) - | Palclrd (dst: ireg) (addr: ireg) - | Palclrw (dst: ireg) (addr: ireg) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - - (** Loads **) - | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) - | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) - | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) - - (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) - | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) - - | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - - (** Arith RR *) - | Pmv (rd rs: ireg) (**r register move *) - | Pnegw (rd rs: ireg) (**r negate word *) - | Pnegl (rd rs: ireg) (**r negate long *) - | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) - | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) - - | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - - | Pfabsd (rd rs: ireg) (**r float absolute double *) - | Pfabsw (rd rs: ireg) (**r float absolute word *) - | Pfnegd (rd rs: ireg) (**r float negate double *) - | Pfnegw (rd rs: ireg) (**r float negate word *) - | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) - | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) - | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) - | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) - | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) - | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) - | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) - | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) - - (** Arith RI32 *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - - (** Arith RI64 *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - - (** Arith RF32 *) - | Pmakefs (rd: ireg) (imm: float32) - - (** Arith RF64 *) - | Pmakef (rd: ireg) (imm: float) - - (** Arith RRR *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) - | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) - - | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Pmulw (rd rs1 rs2: ireg) (**r mul word *) - | Pandw (rd rs1 rs2: ireg) (**r and word *) - | Pnandw (rd rs1 rs2: ireg) (**r nand word *) - | Porw (rd rs1 rs2: ireg) (**r or word *) - | Pnorw (rd rs1 rs2: ireg) (**r nor word *) - | Pxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pandnw (rd rs1 rs2: ireg) (**r andn word *) - | Pornw (rd rs1 rs2: ireg) (**r orn word *) - | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) - | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) - | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) - | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) - | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) - | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) - - | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) - | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) - | Pandl (rd rs1 rs2: ireg) (**r and long *) - | Pnandl (rd rs1 rs2: ireg) (**r nand long *) - | Porl (rd rs1 rs2: ireg) (**r or long *) - | Pnorl (rd rs1 rs2: ireg) (**r nor long *) - | Pxorl (rd rs1 rs2: ireg) (**r xor long *) - | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) - | Pandnl (rd rs1 rs2: ireg) (**r andn long *) - | Pornl (rd rs1 rs2: ireg) (**r orn long *) - | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) - | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) - | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) - | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) - - | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) - | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) - | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) - | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) - | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) - | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) - | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) - | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) - | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) - | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - | Pfinvw (rd rs1: ireg) (**r Float invert word *) - - (** Arith RRI32 *) - | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) - - | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) - | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) - | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) - | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) - | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) - | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) - | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) - | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) - | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) - | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) - | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) - | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - - (** Arith RRI64 *) - | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) - | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) - | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) - | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) - | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) - | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) - | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) - | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) - | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) - | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) -. - -(** Correspondance between Asmblock and Asm *) - -Definition control_to_instruction (c: control) := - match c with - | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmvliw.Pret => Pret - | PCtlFlow (Asmvliw.Pcall l) => Pcall l - | PCtlFlow (Asmvliw.Picall r) => Picall r - | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l - | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l - | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l - | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label - end. - -Definition basic_to_instruction (b: basic) := - match b with - (** Special basics *) - | Asmvliw.Pget rd rs => Pget rd rs - | Asmvliw.Pset rd rs => Pset rd rs - | Asmvliw.Pnop => Pnop - | Asmvliw.Pallocframe sz pos => Pallocframe sz pos - | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos - - (** PArith basics *) - (* R *) - | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs - - (* RR *) - | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs - | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs - | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start - | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start - | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start - | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start - | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs - | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs - - (* RI32 *) - | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm - - (* RI64 *) - | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm - - (* RF32 *) - | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm - - (* RF64 *) - | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm - - (* RRR *) - | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 - | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 - | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 - - | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 - | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 - - (* RRI32 *) - | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm - | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm - | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm - | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm - | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm - - (* RRI64 *) - | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm - | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm - | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm - - (** ARRR *) - | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 - - (** ARR *) - | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start - | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start - - (** ARRI32 *) - | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm - - (** ARRI64 *) - | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm - (** Load *) - | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) - - | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) - | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - - | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) - - | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) - - (** Store *) - | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) - - | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) - - | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) - | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) - end. - -Section RELSEM. - -Definition code := list instruction. - -Fixpoint unfold_label (ll: list label) := - match ll with - | nil => nil - | l :: ll => Plabel l :: unfold_label ll - end. - -Fixpoint unfold_body (lb: list basic) := - match lb with - | nil => nil - | b :: lb => basic_to_instruction b :: unfold_body lb - end. - -Definition unfold_exit (oc: option control) := - match oc with - | None => nil - | Some c => control_to_instruction c :: nil - end. - -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ - (match (body b), (exit b) with - | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => - unfold_body bo - | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil - end). - -Fixpoint unfold (lb: bblocks) := - match lb with - | nil => nil - | b :: lb => (unfold_bblock b) ++ unfold lb - end. - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; - correct: unfold fn_blocks = fn_code }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). - -Definition fundef_proj (fu: fundef) : Asmvliw.fundef := - match fu with - | Internal f => Internal (function_proj f) - | External ef => External ef - end. - -Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := - match gd with - | Gfun f => Gfun (fundef_proj f) - | Gvar gu => Gvar gu - end. - -Program Definition genv_trans (ge: genv) : Asmvliw.genv := - {| Genv.genv_public := Genv.genv_public ge; - Genv.genv_symb := Genv.genv_symb ge; - Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); - Genv.genv_next := Genv.genv_next ge |}. -Next Obligation. - destruct ge. simpl in *. eauto. -Qed. Next Obligation. - destruct ge; simpl in *. - rewrite PTree.gmap1 in H. - destruct (genv_defs ! b) eqn:GEN. - - eauto. - - discriminate. -Qed. Next Obligation. - destruct ge; simpl in *. - eauto. -Qed. - -Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmvliw.fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l - end. - -Definition program_proj (p: program) : Asmvliw.program := - {| prog_defs := prog_defs_proj (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -End RELSEM. - -Definition semantics (p: program) := Asmvliw.semantics (program_proj p). - -(** Determinacy of the [Asm] semantics. *) - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. - intros. apply semantics_determinate. -Qed. - -(** transf_program *) - -Program Definition transf_function (f: Asmvliw.function) : function := - {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; - fn_code := unfold (Asmvliw.fn_blocks f) |}. - -Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. -Proof. - intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. -Qed. - -Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. - -Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. -Proof. - intros f. destruct f as [f|e]; simpl; auto. - rewrite transf_function_proj. auto. -Qed. - -Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. - -Definition match_prog (p: Asmvliw.program) (tp: program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - -Section PRESERVATION. - -Variable prog: Asmvliw.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Definition match_states (s1 s2: state) := s1 = s2. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Theorem transf_program_correct: - forward_simulation (Asmvliw.semantics prog) (semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. - subst. unfold semantics. rewrite transf_program_proj. - - eapply forward_simulation_step with (match_states := match_states); simpl; auto. - - intros. exists s1. split; auto. congruence. - - intros. inv H. auto. - - intros. exists s1'. inv H0. split; auto. congruence. -Qed. - -End PRESERVATION. +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Prashanth Mundkur, SRI International *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* The contributions by Prashanth Mundkur are reused and adapted *) +(* under the terms of a Contributor License Agreement between *) +(* SRI International and INRIA. *) +(* *) +(* *********************************************************************) + +(** * Abstract syntax for K1c textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index b3e0ee23..e130df45 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,274 +1,274 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for RISC-V generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. -Require Import Axioms. - -Module MB := Machblock. -Module AB := Asmvliw. - -Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Machblock.program. -Variable tprog: Asmvliw.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) - -Lemma gen_bblocks_label: - forall hd bdy ex tbb tc, - gen_bblocks hd bdy ex = tbb::tc -> - header tbb = hd. -Proof. - intros until tc. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma gen_bblocks_label2: - forall hd bdy ex tbb1 tbb2, - gen_bblocks hd bdy ex = tbb1::tbb2::nil -> - header tbb2 = nil. -Proof. - intros until tbb2. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + Remark in_dec_transl: - forall lbl hd, - (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). -Proof. - intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. -Qed. - -Lemma transl_is_label: - forall lbl bb tbb f ep tc, - transl_block f bb ep = OK (tbb::tc) -> - is_label lbl tbb = MB.is_label lbl bb. -Proof. - intros until tc. intros TLB. - destruct tbb as [thd tbdy tex]; simpl in *. - monadInv TLB. - unfold is_label. simpl. - apply gen_bblocks_label in H0. simpl in H0. subst. - rewrite in_dec_transl. auto. -Qed. - -Lemma transl_is_label_false2: - forall lbl bb f ep tbb1 tbb2, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb2 = false. -Proof. - intros until tbb2. intros TLB. - destruct tbb2 as [thd tbdy tex]; simpl in *. - monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. - apply is_label_correct_false. simpl. auto. -Qed. - -Lemma transl_is_label2: - forall f bb ep tbb1 tbb2 lbl, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb1 = MB.is_label lbl bb - /\ is_label lbl tbb2 = false. -Proof. - intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. -Qed. - -Lemma transl_block_nonil: - forall f c ep tc, - transl_block f c ep = OK tc -> - tc <> nil. -Proof. - intros. monadInv H. unfold gen_bblocks. - destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. - all: discriminate. -Qed. - -Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, - ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). -Proof. - intros. intro. monadInv H. - unfold gen_bblocks in H0. - destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. - all: discriminate. -Qed. - -Lemma find_label_transl_false: - forall x f lbl bb ep x', - transl_block f bb ep = OK x -> - MB.is_label lbl bb = false -> - find_label lbl (x++x') = find_label lbl x'. -Proof. - intros until x'. intros TLB MBis; simpl; auto. - destruct x as [|x0 x1]; simpl; auto. - destruct x1 as [|x1 x2]; simpl; auto. - - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. - - destruct x2 as [|x2 x3]; simpl; auto. - + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. - erewrite transl_is_label_false2; eauto. - + apply transl_block_limit in TLB. destruct TLB. -Qed. - -Lemma transl_blocks_label: - forall lbl f c tc ep, - transl_blocks f c ep = OK tc -> - match MB.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. - destruct (MB.is_label lbl a) eqn:MBis. - - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } - simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. - rewrite ABis. - eexists. eexists. split; eauto. simpl transl_blocks. - assert (MB.header a <> nil). - { apply MB.is_label_correct_true in MBis. - destruct (MB.header a). contradiction. discriminate. } - destruct (MB.header a); try contradiction. - rewrite EQ. simpl. rewrite EQ1. simpl. auto. - - apply IHc in EQ1. destruct (MB.find_label lbl c). - + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. - erewrite find_label_transl_false; eauto. - + erewrite find_label_transl_false; eauto. -Qed. - -Lemma find_label_nil: - forall bb lbl c, - header bb = nil -> - find_label lbl (bb::c) = find_label lbl c. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. subst. - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { erewrite <- is_label_correct_false. simpl. auto. } - rewrite H. auto. -Qed. - + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + Theorem transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match MB.find_label lbl f.(MB.fn_code) with - | None => find_label lbl tf.(fn_blocks) = None - | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. - eapply transl_blocks_label; eauto. -Qed. - -End TRANSL_LABEL. - + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + (** A valid branch in a piece of Machblock code translates to a valid ``go to'' transition in the generated Asmblock code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - MB.find_label lbl f.(MB.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros (tc & A & B). - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -Lemma return_address_exists: + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmblockgenproof0.return_address_exists; eauto. - -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. exists x; exists true; split; auto. - repeat constructor. + repeat constructor. - exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - +Qed. + +(** * Proof of semantic preservation *) + (** Semantic preservation is proved using a complex simulation diagram - of the following form. -<< + of the following form. +<< MB.step ----------------------------------------> header body exit @@ -283,54 +283,54 @@ Qed. | / match_asmstate \ | st'1 ---------------------------------------> st'2 AB.step * ->> +>> The invariant between each MB.step/AB.step is the [match_states] predicate below. However, we also need to introduce an intermediary state [Codestate] which allows us to reason on a finer grain, executing header, body and exit separately. - + This [Codestate] consists in a state like [Asmblock.State], except that the code is directly stored in the state, much like [Machblock.State]. It also features additional useful elements to keep track of while executing a bblock. *) - -Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of MFP). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Machblock.State s fb sp c ms m) - (Asmvliw.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Machblock.Callstate s fb ms m) - (Asmvliw.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machblock.Returnstate s ms m) - (Asmvliw.State rs m'). - -Record codestate := + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := Codestate { pstate: state; (**r projection to Asmblock.state *) - pheader: list label; + pheader: list label; pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) @@ -341,869 +341,869 @@ Record codestate := (* The part that deals with Machblock <-> Codestate agreement * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m0) - (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) - (TIC: transl_instr_control f (MB.exit bb) = OK tbi) - (TBLS: transl_blocks f c false = OK tc) - (AG: agree ms sp rs0) - (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) - , - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - {| pstate := (Asmvliw.State rs0 m0); - pheader := (MB.header bb); - pbody1 := tbc; +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; pbody2 := extract_basic tbi; - pctl := extract_ctl tbi; + pctl := extract_ctl tbi; ep := ep; - rem := tc; + rem := tc; cur := tbb - |} -. - + |} +. + (* The part ensuring that the code in Codestate actually resides at [rs PC] *) -Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := - | match_asmstate_some: - forall rs f tf tc m tbb ofs ep tbdy tex lhd - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (TRANSF: transf_function f = OK tf) - (PCeq: rs PC = Vptr fb ofs) - (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) - , - match_asmstate fb - {| pstate := (Asmvliw.State rs m); - pheader := lhd; - pbody1 := tbdy; - pbody2 := extract_basic tex; - pctl := extract_ctl tex; +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; ep := ep; - rem := tc; + rem := tc; cur := tbb |} - (Asmvliw.State rs m) -. - + (Asmvliw.State rs m) +. + (* Useful for dealing with the many cases in some proofs *) -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + (** Some translation properties *) -Lemma transl_blocks_nonil: - forall f bb c tc ep, - transl_blocks f (bb::c) ep = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - -Lemma no_builtin_preserved: - forall f ex x2, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x2 -> - (exists i, extract_ctl x2 = Some (PCtlFlow i)) - \/ extract_ctl x2 = None. -Proof. - intros until x2. intros Hbuiltin TIC. - destruct ex. - - destruct c. - (* MBcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBtailcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBbuiltin *) - + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). - apply Hbuiltin. contradict H; auto. - (* MBgoto *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBcond *) - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. - * unfold transl_opt_compuimm. exploreInst; simpl; eauto. - * unfold transl_opt_compluimm. exploreInst; simpl; eauto. - * unfold transl_comp_float64. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. - * unfold transl_comp_float32. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - (* MBjumptable *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBreturn *) - + simpl in TIC. monadInv TIC. simpl. eauto. - - monadInv TIC. simpl; auto. -Qed. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) - /\ transl_blocks f c false = OK tc. -Proof. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. intros until ep0. intros TLBS Hbuiltin. - destruct bb as [hd bdy ex]. - monadInv TLBS. monadInv EQ. - exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. - - destruct H as [i Hectl]. - unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. - simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite Hectl. auto. - - unfold gen_bblocks in H0. rewrite H in H0. - destruct x1 as [|bi x1]. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - (tbdy <> nil \/ extract_ctl tex <> None) -> - (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = tbdy ++ extract_basic tex - /\ exit tbb = extract_ctl tex. -Proof. - intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl tex) eqn:ECTL. - - destruct c. - + destruct i; try (inv GENB; simpl; auto; fail). - assert False. eapply Hnobuiltin. eauto. destruct H. - + inv GENB. simpl. auto. - - inversion Hnonil. - + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. - + contradict H; simpl; auto. -Qed. - -Lemma transl_instr_basic_nonil: - forall k f bi ep x, - transl_instr_basic f bi ep k = OK x -> - x <> nil. -Proof. - intros until x. intros TIB. - destruct bi. - - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. - - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. - - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. - - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. - unfold transl_cond_op in EQ0. exploreInst; try discriminate. - unfold transl_cond_float64. exploreInst; try discriminate. - unfold transl_cond_notfloat64. exploreInst; try discriminate. - unfold transl_cond_float32. exploreInst; try discriminate. - unfold transl_cond_notfloat32. exploreInst; try discriminate. - - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. - - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. -Qed. - -Lemma transl_basic_code_nonil: - forall bdy f x ep, - bdy <> nil -> - transl_basic_code f bdy ep = OK x -> - x <> nil. -Proof. - induction bdy as [|bi bdy]. - intros. contradict H0; auto. - destruct bdy as [|bi2 bdy]. - - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. - - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. - monadInv TBC. - assert (x0 <> nil). - eapply IHbdy; eauto. subst bdy'. discriminate. - eapply transl_instr_basic_nonil; eauto. -Qed. - -Lemma transl_instr_control_nonil: - forall ex f x, - ex <> None -> - transl_instr_control f ex = OK x -> - extract_ctl x <> None. -Proof. - intros ex f x Hnonil TIC. - destruct ex as [ex|]. - - clear Hnonil. destruct ex. - all: try (simpl in TIC; exploreInst; discriminate). - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. - * unfold transl_opt_compuimm. exploreInst; try discriminate. - * unfold transl_opt_compluimm. exploreInst; try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. - - contradict Hnonil; auto. -Qed. - -Lemma transl_instr_control_nobuiltin: - forall f ex x, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x -> - (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). -Proof. - intros until x. intros Hnobuiltin TIC. intros until res. - unfold transl_instr_control in TIC. exploreInst. - all: try discriminate. - - assert False. eapply Hnobuiltin; eauto. destruct H. - - unfold transl_cbranch in TIC. exploreInst. - all: try discriminate. - * unfold transl_opt_compuimm. exploreInst. all: try discriminate. - * unfold transl_opt_compluimm. exploreInst. all: try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. -Qed. - + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + (* Proving that one can decompose a [match_state] relation into a [match_codestate] and a [match_asmstate], along with some helpful properties tying both relations together *) -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m, - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (MB.body bb <> nil \/ MB.exit bb <> None) -> - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - match_states mbs abs -> - exists cs fb f tbb tc ep, - match_codestate fb mbs cs /\ match_asmstate fb cs abs - /\ Genv.find_funct_ptr ge fb = Some (Internal f) - /\ transl_blocks f (bb::c) ep = OK (tbb::tc) - /\ body tbb = pbody1 cs ++ pbody2 cs - /\ exit tbb = pctl cs +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs /\ cur cs = tbb /\ rem cs = tc - /\ pstate cs = abs. -Proof. - intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. - inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. - monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. - { inversion Hnotempty. - - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). - left. eapply transl_basic_code_nonil; eauto. - - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). - right. eapply transl_instr_control_nonil; eauto. } - eapply transl_instr_control_nobuiltin; eauto. - intros (Hth & Htbdy & Htexit). - exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. - repeat split. 1-2: econstructor; eauto. - { destruct (MB.header bb). eauto. discriminate. } eauto. - unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. - rewrite TLBS. simpl. rewrite H2. - all: simpl; auto. -Qed. - -Definition mb_remove_body (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma exec_straight_pnil: - forall c rs1 m1 rs2 m2, + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb ep tbb, - (MB.body bb <> nil \/ MB.exit bb <> None) -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - transl_block f bb ep = OK (tbb :: nil) -> - exists c c', - transl_basic_code f (MB.body bb) ep = OK c - /\ transl_instr_control f (MB.exit bb) = OK c' - /\ body tbb = c ++ extract_basic c' - /\ exit tbb = extract_ctl c'. -Proof. - intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. -Qed. - -Lemma nextblock_preserves: - forall rs rs' bb r, - rs' = nextblock bb rs -> - data_preg r = true -> - rs r = rs' r. -Proof. - intros. destruct r; try discriminate. - subst. Simpl. -Qed. - + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +Qed. + Remark cons3_app {A: Type}: - forall a b c (l: list A), - a :: b :: c :: l = (a :: b :: c :: nil) ++ l. -Proof. - intros. simpl. auto. -Qed. - -Lemma exec_straight_opt_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight_opt tge c rs1 m1 c' rs2 m2 -> - exists body, - exec_body tge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. intros EXES. - inv EXES. - - exists nil. split; auto. - - eapply exec_straight_body2. auto. -Qed. - -Lemma extract_basics_to_code: - forall lb c, - extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -Lemma extract_ctl_basics_to_code: - forall lb c, - extract_ctl (basics_to_code lb ++ c) = extract_ctl c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + (* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by yourself the steps *) -Theorem step_simu_control: +Theorem step_simu_control: forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, - MB.body bb' = nil -> - (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> - Genv.find_funct_ptr tge fb = Some (Internal fn) -> - pstate cs2 = (Asmvliw.State rs2 m2) -> - pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> cur cs2 = tbb -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> - (exists rs3 m3 rs4 m4, - exec_body tge tbdy2 rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. - inv ESTEP. - - inv MCS. inv MAS. simpl in *. + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. inv Hpstate. - destruct ctl. - + (* MBcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct s1 as [rf|fid]; simpl in H7. - * (* Indirect call *) - monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. - revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - { econstructor; eauto. } - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. - - * (* Direct call *) - monadInv H1. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - econstructor; eauto. - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. - destruct s1 as [rf|fid]; simpl in H13. - * monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - - assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - { simpl. eauto. } - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). - { clear - EQ. destruct x; repeat split; try discriminate. - all: unfold ireg_of in EQ; destruct rf; try discriminate. } - Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. - * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } - + (* MBbuiltin (contradiction) *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. - remember (nextblock tbb rs2) as rs2'. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - exploit find_label_goto_label. - eauto. eauto. - instantiate (2 := rs2'). - { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } - eauto. - intros (tc' & rs' & GOTO & AT2 & INV). - - eexists. eexists. repeat eexists. repeat split. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. - econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. - eapply agree_exten; eauto with asmgen. - assert (forall r : preg, r <> PC -> rs' r = rs2 r). - { intros. destruct r. - - destruct g. all: rewrite INV; Simpl; auto. - - rewrite INV; Simpl; auto. - - contradiction. } - eauto with asmgen. - congruence. - + (* MBcond *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - * (* MBcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. - 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. - unfold Val.offset_ptr. rewrite PCeq. eauto. - intros (tc' & rs3 & GOTOL & TLPC & Hrs3). - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - - * (* MBcond false *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - - exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - monadInv H1. - generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. - - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - - repeat eexists. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. - econstructor; eauto. - eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. - { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. - destruct (preg_eq r' GPR63). subst. contradiction. - destruct (preg_eq r' GPR62). subst. contradiction. - destruct r'; Simpl. } - discriminate. - + (* MBreturn *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - assert (f1 = f) by congruence. subst f1. - - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. destruct bb' as [hd' bdy' ex']; simpl in *. subst. - monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. - simpl. repeat eexists. - econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - assert (f = f0) by congruence. subst f0. econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - discriminate. -Qed. - -Definition mb_remove_first (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. - -Lemma exec_straight_body: - forall c c' lc rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 c' rs2 m2 -> - code_to_basics c = Some lc -> - exists l ll, - c = l ++ c' - /\ code_to_basics l = Some ll - /\ exec_body tge ll rs1 m1 = Next rs2 m2. -Proof. - induction c; try (intros; inv H; fail). - intros until m2. intros EXES CTB. inv EXES. - - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. - - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. - eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. - exists (i ::g l'),(i::ll). repeat (split; simpl; auto). - rewrite CTB. auto. - rewrite H1. auto. -Qed. - -Lemma basics_to_code_app: - forall c l x ll, - basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - c = ll ++ x. -Proof. - intros. apply (f_equal code_to_basics) in H. - erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. - rewrite code_to_basics_id in H. inv H. auto. -Qed. - -Lemma basics_to_code_app2: - forall i c l x ll, - (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - i :: c = ll ++ x. -Proof. - intros until ll. intros. - exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. - all: eauto. -Qed. - + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + (* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) Theorem step_simu_basic: - forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> - basic_step ge s fb sp ms m bi ms' m' -> - pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 l cs2 tbdy', - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} - /\ tbdy = l ++ tbdy' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). -Proof. - intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. - simpl in *. inv Hpstate. - rewrite Hbody in TBC. monadInv TBC. - inv BSTEP. - - - (* MBgetstack *) - simpl in EQ0. - unfold Mach.load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - exploit loadind_correct; eauto with asmgen. - intros (rs2 & EXECS & Hrs'1 & Hrs'2). - eapply exec_straight_body in EXECS. - 2: eapply code_to_basics_id; eauto. - destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). - exists rs2, m1, Hlbi. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } subst. simpl in Hheadereq. - + eapply match_codestate_intro; eauto. { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } - eapply agree_set_mreg; eauto with asmgen. + eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. destruct (andb_prop _ _ Hep). clear Hep. rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. discriminate. apply preg_of_not_FP; assumption. reflexivity. - - (* MBsetstack *) - simpl in EQ0. - unfold Mach.store_stack in H. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - exploit storeind_correct; eauto with asmgen. - rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs', m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - - eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - - (* MBgetparam *) - simpl in EQ0. - - assert (f0 = f) by congruence; subst f0. - unfold Mach.load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. - - monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. destruct ep0 eqn:EPeq. - (* RTMP contains parent *) - + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & BTC & CTB & EXECB). - exists rs2, m1, ll. eexists. - eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - { eapply basics_to_code_app; eauto. } - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } subst. - eapply match_codestate_intro; eauto. - - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_FP; auto. - + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + (* RTMP does not contain parent *) - + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. - intros [rs3 [S [T U]]]. - - exploit exec_straight_trans. - eapply P. - eapply S. - intros EXES. - - eapply exec_straight_body in EXES. - 2: simpl. 2: erewrite code_to_basics_id; eauto. - destruct EXES as (l & ll & BTC & CTB & EXECB). - exists rs3, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app2; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. - eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs2#FP <- (rs3#FP)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_FP; auto. - - (* MBop *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_operation tge sp op (map ms args) m' = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. - eapply preg_vals; eauto. - 2: eexact H0. - all: eauto. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - apply agree_set_undef_mreg with rs1; auto. - apply Val.lessdef_trans with v'; auto. - simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_FP; auto. -Local Transparent destroyed_by_op. - destruct op; simpl; auto; congruence. - - (* MBload *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. eapply agree_set_mreg; eauto with asmgen. intro Hep. simpl in Hep. destruct (andb_prop _ _ Hep). clear Hep. subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. apply preg_of_not_FP; assumption. reflexivity. - - - (* notrap1 cannot happen *) - simpl in EQ0. unfold transl_load in EQ0. - destruct addr; simpl in H. - all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; - monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; - destruct args as [|h0 t0]; try discriminate; - destruct t0 as [|h1 t1]; try discriminate; - destruct t1 as [|h2 t2]; try discriminate. - - - (* MBload notrap2 TODO *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - - destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. - { - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. + + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. @@ -1215,406 +1215,406 @@ Local Transparent destroyed_by_op. destruct ep0; simpl in *; congruence. apply preg_of_not_FP. destruct ep0; simpl in *; congruence. - } - { - exploit transl_load_correct_notrap2; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. simpl. intro. rewrite R; try congruence. apply DXP. destruct ep0; simpl in *; congruence. apply preg_of_not_FP. destruct ep0; simpl in *; congruence. - } - - (* MBstore *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + } + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. - eapply agree_undef_regs; eauto with asmgen. + eapply agree_undef_regs; eauto with asmgen. intro Hep. simpl in Hep. subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. -Qed. - -Lemma exec_body_trans: - forall l l' rs0 m0 rs1 m1 rs2 m2, - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_body tge l' rs1 m1 = Next rs2 m2 -> - exec_body tge (l++l') rs0 m0 = Next rs2 m2. -Proof. - induction l. - - simpl. congruence. - - intros until m2. intros EXEB1 EXEB2. - inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. - simpl. rewrite EBI. eapply IHl; eauto. -Qed. - -Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. - -Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. -Next Obligation. - destruct tbb. simpl. auto. -Qed. - -Inductive exec_header: codestate -> codestate -> Prop := - | exec_header_cons: forall cs1, - exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - cur := cur cs1 |}. - + cur := cur cs1 |}. + (* Theorem (A) in the diagram, the easiest of all *) Theorem step_simu_header: - forall bb s fb sp c ms m rs1 m1 cs1, - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists cs1', - exec_header cs1 cs1' - /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). -Proof. - intros until cs1. intros Hpstate MCS. - eexists. split; eauto. - econstructor; eauto. - inv MCS. simpl in *. inv Hpstate. - econstructor; eauto. -Qed. - -Lemma step_matchasm_header: - forall fb cs1 cs1' s1, - match_asmstate fb cs1 s1 -> - exec_header cs1 cs1' -> - match_asmstate fb cs1' s1. -Proof. - intros until s1. intros MAS EXH. - inv MAS. inv EXH. - simpl. econstructor; eauto. -Qed. - + forall bb s fb sp c ms m rs1 m1 cs1, + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + (* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) Theorem step_simu_body: - forall bb s fb sp c ms m rs1 m1 ms' cs1 m', - MB.header bb = nil -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 cs2 ep, - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} - /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). -Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. - inv BSTEP. + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. exists rs1, m1, cs1, (ep cs1). - inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). - econstructor; eauto. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. - exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. - intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). - simpl in *. - exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. - intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). - exists rs3, m3, cs3, ep. - repeat (split; simpl; auto). subst. simpl in *. auto. - rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. -Qed. - -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma exec_body_control: - forall b rs1 m1 rs2 m2 rs3 m3 fn, - exec_body tge (body b) rs1 m1 = Next rs2 m2 -> - exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel tge fn b rs1 m1 rs3 m3. -Proof. - intros until fn. intros EXEB EXECTL. - econstructor; eauto. inv EXECTL. - unfold exec_bblock. rewrite EXEB. auto. -Qed. - -Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. - -Lemma mbsize_eqz: - forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. - remember (length _) as a. remember (length_opt _) as b. - assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. - inv H0. inv H1. destruct bdy; destruct ex; auto. - all: try discriminate. -Qed. - -Lemma mbsize_neqz: - forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. - destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). - contradict H. unfold mbsize. simpl. auto. -Qed. - + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +Lemma exec_body_pc: + forall l rs1 m1 rs2 m2, + exec_body tge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + (* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) (* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, - bb' = mb_remove_header bb -> - body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> - bb'' = mb_remove_body bb' -> - (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. -Proof. - intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. - destruct (mbsize bb) eqn:SIZE. - - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. - inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - monadInv H2. simpl in *. inv ESTEP. inv BSTEP. - eexists. split. eapply plus_one. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - assert (x = tf) by congruence. subst x. - eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. - unfold exec_bblock. simpl. eauto. - econstructor. eauto. eauto. eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - intros. discriminate. - - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } - intros Hnotempty. - - (* initial setting *) - exploit match_state_codestate. - 2: eapply Hnotempty. - all: eauto. - intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - - (* step_simu_header part *) - assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } - destruct H as (rs1 & m1 & Hpstate2). subst. - assert (f = fb). { inv MCS. auto. } subst fb. - exploit step_simu_header. - 2: eapply MCS. - all: eauto. - intros (cs1' & EXEH & MCS2). - - (* step_simu_body part *) - assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } - exploit step_simu_body. - 3: eapply BSTEP. - 4: eapply MCS2. - all: eauto. rewrite Hpstate'. eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). - - (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). - { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } - destruct H as (tf & FIND'). - assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). - { inv MAS. simpl in *. eauto. } - destruct H as (tex & Hpbody2 & Hpctl). - inv EXEH. simpl in *. - subst. exploit step_simu_control. - 9: eapply MCS'. all: simpl. - 10: eapply ESTEP. - all: simpl; eauto. +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. rewrite Hpbody2. rewrite Hpctl. { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. - erewrite exec_body_pc; eauto. } - intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). - - (* bringing the pieces together *) - exploit exec_body_trans. - eapply EXEB. - eauto. - intros EXEB2. - exploit exec_body_control; eauto. - rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. - rewrite Hexit. rewrite Hpctl. eauto. - intros EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr f ofs). - { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } - destruct H0 as (ofs & Hrs1pc). - eapply exec_step_internal; eauto. - - (* proving the initial find_bblock *) - rewrite Hpstate2 in MAS. inv MAS. simpl in *. - assert (f1 = f0) by congruence. subst f0. - rewrite PCeq in Hrs1pc. inv Hrs1pc. - exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. - eapply find_bblock_tail; eauto. -Qed. - + eapply find_bblock_tail; eauto. +Qed. + Theorem step_simulation_bblock: - forall sf f sp bb ms m ms' m' S2 c, - body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. -Proof. - intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. - eapply step_simulation_bblock'; eauto. - all: destruct bb as [hd bdy ex]; simpl in *; eauto. - inv ESTEP. - - econstructor. inv H; try (econstructor; eauto; fail). - - econstructor. -Qed. - + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + (** Dealing now with the builtin case *) - -Definition split (c: MB.code) := - match c with - | nil => nil - | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} - :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c - end. - -Lemma cons_ok_eq3 {A: Type} : - forall (x:A) y z x' y' z', - x = x' -> y = y' -> z = z' -> - OK (x::y::z) = OK (x'::y'::z'). -Proof. - intros. subst. auto. -Qed. - -Lemma transl_blocks_split_builtin: - forall bb c ep f ef args res, - MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> - transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. -Proof. - intros until res. intros Hexit Hbody. simpl split. - unfold transl_blocks. fold transl_blocks. unfold transl_block. - simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. - remember (transl_blocks _ _ _) as tlbs. - destruct tbc; destruct tbi; destruct tlbs. - all: try simpl; auto. - - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. - unfold gen_bblocks. simpl. destruct l. - + exploit transl_basic_code_nonil; eauto. intro. destruct H. - + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. -Qed. - -Lemma transl_code_at_pc_split_builtin: - forall rs f f0 bb c ep tf tc ef args res, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> - transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. -Proof. - intros until res. intros Hbody Hexit AT. inv AT. - econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. -Qed. - -Theorem match_states_split_builtin: - forall sf f sp bb c rs m ef args res S1, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. -Proof. - intros until S1. intros Hbody Hexit MS. - inv MS. - econstructor; eauto. - eapply transl_code_at_pc_split_builtin; eauto. -Qed. - + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + Theorem step_simulation_builtin: - forall ef args res bb sf f sp c ms m t S2, - MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. -Proof. - intros until S2. intros Hbody Hexit ESTEP S1' MS. - inv MS. inv AT. monadInv H2. monadInv EQ. - rewrite Hbody in EQ0. monadInv EQ0. - rewrite Hexit in EQ. monadInv EQ. - rewrite Hexit in ESTEP. inv ESTEP. inv H4. - - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H1); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - econstructor; split. apply plus_one. - simpl in H3. - eapply exec_step_builtin. eauto. eauto. - eapply find_bblock_tail; eauto. - simpl. eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock, incrPC. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextblock. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - apply Pregmap.gso; auto with asmgen. - congruence. -Qed. - -Lemma next_sep: - forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - congruence. -Qed. - + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + (* Measure to prove finite stuttering, see the other backends *) Definition measure (s: MB.state) : nat := match s with @@ -1625,193 +1625,193 @@ Definition measure (s: MB.state) : nat := (* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs for the internal and external function cases *) -Theorem step_simulation: - forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros. - -- (* bblock *) - left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. - all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; - try (rewrite MBE; try discriminate); eauto). - + (* MBbuiltin *) - destruct (MB.body bb) eqn:MBB. - * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. - * eapply match_states_split_builtin in MS; eauto. - 2: rewrite MBB; discriminate. - simpl split in MS. - rewrite <- MBB in H. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. - assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } - rewrite H1 in H. subst. - exploit step_simulation_bblock. eapply H. - discriminate. - simpl. constructor. - eauto. - intros (S2' & PLUS1 & MS'). - rewrite MBE in MS'. - assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) - (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) - rs' m') t s'). - { inv H0. inv H3. econstructor. econstructor; eauto. } - exploit step_simulation_builtin. - 4: eapply MS'. - all: simpl; eauto. - intros (S3' & PLUS'' & MS''). - exists S3'. split; eauto. - eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. - + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - -- (* internal function *) - inv MS. - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. - unfold Mach.store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - (* Execution of function prologue *) +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) monadInv EQ0. - set (tfbody := make_prologue f x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). - exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). { rewrite chunk_of_Tptr in P. - assert (rs' GPRA = rs0 RA). { apply V'. } - assert (rs' SP = rs2 SP). { apply V'; discriminate. } - rewrite H4. rewrite H3. - rewrite ATLR. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + rewrite ATLR. change (rs2 SP) with sp. eexact P. } - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: exists rs3', - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3' - /\ forall r, r <> PC -> rs3' r = rs3 r). - { eexists. split. - - change (fn_blocks tf) with tfbody; unfold tfbody. - econstructor; eauto. unfold exec_bblock. simpl exec_body. - rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. - Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. - rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. - simpl. apply next_sep; eauto. reflexivity. - - intros. destruct V' as (V'' & V'). destruct r. - + Simpl. - destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } - + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. - + contradiction. - } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3' m3'); split. - eapply exec_straight_steps_1; eauto. - simpl fn_blocks. simpl fn_blocks in g. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. - simpl; intros; Simpl. - unfold sp; congruence. - - intros. - assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. - assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - intros. rewrite Heqrs3'. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. discriminate. - -- (* external function *) - inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. - apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, MB.initial_state prog st1 -> - exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Mach.Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - Asmblockgenproof0.return_address_offset. - -Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - - apply senv_preserved. - - eexact transf_initial_states. - - eexact transf_final_states. - - exact step_simulation. -Qed. - -End PRESERVATION. + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. + +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 9937f23871513d4bf77db5b541a93f6327365f1e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Dec 2019 19:08:50 +0100 Subject: begin overlap proofs --- mppa_k1c/Asmblockdeps.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c7cfe43c..2b2627e7 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -22,6 +22,8 @@ Require Import Parallelizability. Require Import Asmvliw Permutation. Require Import Chunks. +Require Import Lia. + Open Scope impure. (** Definition of L *) @@ -208,6 +210,47 @@ Definition store_eval (so: store_op) (l: list value) := | _, _ => None end. +Local Open Scope Z. + +Definition no_overlap_segments l1 h1 l2 h2 := + (h1 <=? l2) || (h2 <=? l1). + +Definition in_segment l h x := + (l <=? x) && (x + (in_segment l2 h2 x) = true -> + (no_overlap_segments l1 h1 l2 h2) = false. +Proof. + unfold in_segment, no_overlap_segments. + intros until x. + intros H1 H2. + destruct (andb_true_iff (l1 <=? x) (x + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From fd1d1f8c981332afad01b36915bc5b06d4066f70 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Dec 2019 15:24:27 +0100 Subject: some subgoal was proved --- mppa_k1c/Asmblockdeps.v | 67 ++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 61 insertions(+), 6 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2b2627e7..0f534350 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -244,13 +244,68 @@ Proof. rewrite Z.leb_le. lia. Qed. - -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1', - store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1'] = Some (Memstate m2). +Definition no_overlap_chunks + (ofs1 : offset) (chunk1 : memory_chunk) + (ofs2 : offset) (chunk2 : memory_chunk) := + no_overlap_segments (Ptrofs.unsigned ofs1) + ((Ptrofs.unsigned ofs1) + (size_chunk chunk1)) + (Ptrofs.unsigned ofs2) + ((Ptrofs.unsigned ofs2) + (size_chunk chunk2)). + +Definition same_memory (m m' : mem) := + forall chunk block ofs, + (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). + +(* use something like load_store_other *) +Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', + (no_overlap_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2))=true -> + same_memory m0 m0' -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> + same_memory m2 m2'. +Proof. + intros until m2'. + intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. + unfold same_memory. + intros rchunk rblock rofs. + unfold no_overlap_chunks in NO_OVERLAP. + unfold no_overlap_segments in NO_OVERLAP. + rewrite orb_true_iff in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + rewrite Z.leb_le in NO_OVERLAP. + destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. + destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + destruct Ge. + destruct (eval_offset ofs1) as [ i1 |]; try congruence. + destruct (eval_offset ofs2) as [ i2 |]; try congruence. + unfold Mem.storev in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + inv STORE0. + destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + inv STORE1. + destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + inv STORE0'. + destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + inv STORE1'. + destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. + { admit. + } + { (* read from different base block *) + rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. + rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. + rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. + apply SAME. + } +Admitted. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From db03f4f3f90d7eab399177fc3f27ac027c10bc9f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Dec 2019 13:10:01 +0100 Subject: progress in chunks --- mppa_k1c/Asmblockdeps.v | 54 +++++++++---------------------------------------- 1 file changed, 9 insertions(+), 45 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 0f534350..c54cc317 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,46 +212,13 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. -Definition no_overlap_segments l1 h1 l2 h2 := - (h1 <=? l2) || (h2 <=? l1). - -Definition in_segment l h x := - (l <=? x) && (x - (in_segment l2 h2 x) = true -> - (no_overlap_segments l1 h1 l2 h2) = false. -Proof. - unfold in_segment, no_overlap_segments. - intros until x. - intros H1 H2. - destruct (andb_true_iff (l1 <=? x) (x + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> same_memory m0 m0' -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> @@ -271,11 +238,7 @@ Proof. intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. unfold same_memory. intros rchunk rblock rofs. - unfold no_overlap_chunks in NO_OVERLAP. - unfold no_overlap_segments in NO_OVERLAP. - rewrite orb_true_iff in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. - rewrite Z.leb_le in NO_OVERLAP. + unfold disjoint_chunks in NO_OVERLAP. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. destruct va as [base | ]; try congruence. @@ -295,7 +258,8 @@ Proof. destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. inv STORE1'. destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { admit. + { subst rblock. + admit. } { (* read from different base block *) rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. -- cgit From ce3f5cd4afdd5f5794b9c0a7480947b25e3685d0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Dec 2019 08:58:12 +0100 Subject: comment out theorem that cannot be proved --- mppa_k1c/Asmblockdeps.v | 62 ++++++++++++++++++++++++++----------------------- 1 file changed, 33 insertions(+), 29 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index c54cc317..4d53763c 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -212,6 +212,12 @@ Definition store_eval (so: store_op) (l: list value) := Local Open Scope Z. +Remark size_chunk_positive: forall chunk, + (size_chunk chunk) > 0. +Proof. + destruct chunk; simpl; lia. +Qed. + Definition disjoint_chunks (ofs1 : offset) (chunk1 : memory_chunk) (ofs2 : offset) (chunk2 : memory_chunk) := @@ -220,56 +226,54 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -Definition same_memory (m m' : mem) := - forall chunk block ofs, - (Mem.load chunk m block ofs) = (Mem.load chunk m' block ofs). - +(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING (* use something like load_store_other *) Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> - same_memory m0 m0' -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> - same_memory m2 m2'. + m2 = m2'. Proof. intros until m2'. - intros NO_OVERLAP SAME STORE0 STORE1 STORE0' STORE1'. - unfold same_memory. - intros rchunk rblock rofs. - unfold disjoint_chunks in NO_OVERLAP. + intros DISJOINT STORE0 STORE1 STORE0' STORE1'. + unfold disjoint_chunks in DISJOINT. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. destruct va as [base | ]; try congruence. unfold exec_store_deps_offset in *. destruct Ge. - destruct (eval_offset ofs1) as [ i1 |]; try congruence. - destruct (eval_offset ofs2) as [ i2 |]; try congruence. + unfold eval_offset in *; simpl in *. unfold Mem.storev in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store (store_chunk n1) m0 _ _ _) eqn:HS0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. inv STORE0. - destruct (Mem.store (store_chunk n2) m1 _ _ _) eqn:HS1; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. inv STORE1. - destruct (Mem.store (store_chunk n2) m0' _ _ _) eqn:HS0'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. inv STORE0'. - destruct (Mem.store (store_chunk n1) m1' _ _ _) eqn:HS1'; try congruence. + destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. inv STORE1'. - destruct (eq_block rblock wblock) as [SAME_BLOCK | DIF_BLOCKS]. - { subst rblock. - admit. - } - { (* read from different base block *) - rewrite (Mem.load_store_other (store_chunk n2) m1 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m2 HS1) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m0 wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m1 HS0) by tauto. - rewrite (Mem.load_store_other (store_chunk n1) m1' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i1)) v1 m2' HS1') by tauto. - rewrite (Mem.load_store_other (store_chunk n2) m0' wblock (Ptrofs.unsigned (Ptrofs.add wpofs i2)) v2 m1' HS0') by tauto. - apply SAME. - } -Admitted. - + assert (Some m2 = Some m2'). + 2: congruence. + rewrite <- E1. + rewrite <- E1'. + eapply Mem.store_store_other. + { + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + try lia. + } +*) + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From 34518ae5db9ca7c04d9ce5d90261ede3c9d0e550 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 14:45:56 +0100 Subject: swap stores at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 4d53763c..759b4396 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -218,6 +218,12 @@ Proof. destruct chunk; simpl; lia. Qed. +Remark size_chunk_small: forall chunk, + (size_chunk chunk) <= 8. +Proof. + destruct chunk; simpl; lia. +Qed. + Definition disjoint_chunks (ofs1 : offset) (chunk1 : memory_chunk) (ofs2 : offset) (chunk2 : memory_chunk) := @@ -226,18 +232,20 @@ Definition disjoint_chunks ((Ptrofs.unsigned ofs2), ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). -(* THIS CANNOT BE PROVED DUE TO OVERFLOW WRAPPING -(* use something like load_store_other *) -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m0' m1 m2 m1' m2', +Definition small_offset_threshold := 18446744073709551608. + +Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0'] = Some (Memstate m1') -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> m2 = m2'. Proof. intros until m2'. - intros DISJOINT STORE0 STORE1 STORE0' STORE1'. + intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'. unfold disjoint_chunks in DISJOINT. destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. @@ -261,18 +269,24 @@ Proof. rewrite <- E1. rewrite <- E1'. eapply Mem.store_store_other. - { - right. - pose proof (size_chunk_positive (store_chunk n1)). - pose proof (size_chunk_positive (store_chunk n2)). - destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; - unfold Intv.empty in DIS; simpl in DIS. - 1, 2: lia. - destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + 2, 3: eassumption. + + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; - try lia. - } -*) + change Ptrofs.modulus with 18446744073709551616 in *; + lia. +Qed. Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with -- cgit From 26775340b173fd631e850f0a553ddab25c934fbc Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:03:12 +0100 Subject: Stub for opcode heuristic --- mppa_k1c/DuplicateOpcodeHeuristic.ml | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 mppa_k1c/DuplicateOpcodeHeuristic.ml (limited to 'mppa_k1c') diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..fe9307f2 --- /dev/null +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,4 @@ +(* open Camlcoq *) +(* open Op *) + +let opcode_heuristic code cond ifso ifnot preferred = () -- cgit From dc7ba7bf86828da813e60d60dc9627cbd6ddcf0e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 16 Dec 2019 16:45:14 +0100 Subject: swap load and store at disjoint offsets --- mppa_k1c/Asmblockdeps.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 759b4396..2cdf9499 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -234,7 +234,8 @@ Definition disjoint_chunks Definition small_offset_threshold := 18446744073709551608. -Lemma store_swap : forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', +Lemma store_store_disjoint_offsets : + forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> (Ptrofs.unsigned ofs1) < small_offset_threshold -> (Ptrofs.unsigned ofs2) < small_offset_threshold -> @@ -288,6 +289,57 @@ Proof. lia. Qed. +Lemma load_store_disjoint_offsets : + forall n1 n2 tm ofs1 ofs2 vs va m0 m1, + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) -> + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] = + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0]. +Proof. + intros until m1. + intros DISJOINT SMALL1 SMALL2 STORE0. + destruct vs as [v | ]; simpl in STORE0; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + unfold eval_offset in *; simpl in *. + unfold exec_load_deps_offset. + unfold Mem.storev, Mem.loadv in *. + destruct Ge in *. + unfold eval_offset in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + inv STORE0. + assert ( + (Mem.load (load_chunk n2) m1 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) = + (Mem.load (load_chunk n2) m0 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS. + { + eapply Mem.load_store_other. + eassumption. + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (load_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (load_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1,2: lia. + + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. + } + destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. +Qed. + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None -- cgit From aed1bf936b69464f99a92133a43d51664295d780 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 16 Dec 2019 16:55:40 +0100 Subject: Opcode heuristic done for K1c --- mppa_k1c/DuplicateOpcodeHeuristic.ml | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index fe9307f2..690553ce 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -1,4 +1,32 @@ (* open Camlcoq *) -(* open Op *) +open Op +open Integers -let opcode_heuristic code cond ifso ifnot preferred = () +exception HeuristicSucceeded + +let opcode_heuristic code cond ifso ifnot preferred = + let decision = match cond with + | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccompf c | Ccompfs c -> (match c with + | Ceq -> Some false + | Cne -> Some true + | _ -> None + ) + | Cnotcompf c | Cnotcompfs c -> (match c with + | Ceq -> Some true + | Cne -> Some false + | _ -> None + ) + | _ -> None + in match decision with + | Some b -> (preferred := b; raise HeuristicSucceeded) + | None -> () -- cgit From 27767971a256b97ee75deab19a01d575ee01a6e0 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 Jan 2020 15:38:45 +0100 Subject: Fixing issue with "destruct ... in ..." tactics with Coq 8.8 --- mppa_k1c/Asmblockdeps.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 2cdf9499..584f2339 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -257,13 +257,13 @@ Proof. unfold Mem.storev in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. inv STORE0. - destruct (Mem.store _ _ _ _) eqn:E1 in STORE1; try congruence. + destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. inv STORE1. - destruct (Mem.store _ _ _ _) eqn:E0' in STORE0'; try congruence. + destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. inv STORE0'. - destruct (Mem.store _ _ _ _) eqn:E1' in STORE1'; try congruence. + destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. inv STORE1'. assert (Some m2 = Some m2'). 2: congruence. @@ -310,7 +310,7 @@ Proof. unfold eval_offset in *. unfold Val.offset_ptr in *. destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0 in STORE0; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0; try congruence. inv STORE0. assert ( (Mem.load (load_chunk n2) m1 wblock -- cgit From ae8c21b078fda638b706d157e1b9a16e4bcc4ab7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 11:49:05 +0100 Subject: Breaking the prologue to satisfy resource constraints --- mppa_k1c/Asmexpand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index d52bd485..8ab10bc5 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -514,8 +514,8 @@ let expand_instruction instr = end else begin let below = Integers.Ptrofs.repr (Z.neg sz) in expand_addptrofs stack_pointer stack_pointer below; + emit Psemi; (* Psemi required to fit in resource constraints *) expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below); - (* DM we don't need it emit Psemi; *) vararg_start_ofs := None end | Pfreeframe (sz, ofs) -> -- cgit From 56240b6f831e3aeca751c718dace1fd42724749d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:06:46 +0100 Subject: Fixed reservation tables --- mppa_k1c/PostpassSchedulingOracle.ml | 90 ++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 44 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index cdda0e6d..a97fda83 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,7 +442,7 @@ let encode_imm (imm:int64) = else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm (** Resources *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"] +let resource_names = ["ISSUE"; "TINY"; "LITE"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "NOP"] let rec find_index elt l = match l with @@ -457,31 +457,24 @@ let resource_bound resource : int = | "ISSUE" -> 8 | "TINY" -> 4 | "LITE" -> 2 - | "ALU" -> 1 + | "FULL" -> 1 | "LSU" -> 1 | "MAU" -> 1 | "BCU" -> 1 - | "ACC" -> 1 - | "DATA" -> 1 | "TCA" -> 1 - | "BRE" -> 1 - | "BRO" -> 1 + | "AUXR" -> 1 + | "AUXW" -> 1 + | "CRRP" -> 1 + | "CRWL" -> 1 + | "CRWH" -> 1 | "NOP" -> 4 | _ -> raise Not_found let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) (** Reservation tables *) -let alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 +let alu_full : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with @@ -496,24 +489,20 @@ let alu_lite_y : int array = let resmap = fun r -> match r with | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let alu_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - let alu_nop : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let mau_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 +let alu_tiny_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with @@ -524,30 +513,43 @@ let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxr : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxw : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_acc_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0 +let lsu_auxw_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let lsu_auxw_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let mau : int array = let resmap = fun r -> match r with + | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -let lsu_data_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0 +let mau_x : int array = let resmap = fun r -> match r with + | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let mau_y : int array = let resmap = fun r -> match r with + | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + + (** Real instructions *) exception InvalidEncoding @@ -612,13 +614,13 @@ let rec_to_usage r = | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> - (match encoding with None | Some U6 | Some S10 -> lsu_data - | Some U27L5 | Some U27L10 -> lsu_data_x - | Some E27U27L10 -> lsu_data_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxw + | Some U27L5 | Some U27L10 -> lsu_auxw_x + | Some E27U27L10 -> lsu_auxw_y) | Sb | Sh | Sw | Sd | Sq | So -> - (match encoding with None | Some U6 | Some S10 -> lsu_acc - | Some U27L5 | Some U27L10 -> lsu_acc_x - | Some E27U27L10 -> lsu_acc_y) + (match encoding with None | Some U6 | Some S10 -> lsu_auxr + | Some U27L5 | Some U27L10 -> lsu_auxr_x + | Some E27U27L10 -> lsu_auxr_y) | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu | Get -> bcu_tiny_tiny_mau_xnop | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -- cgit From 4d0cc4318d6f46d9575ff7ebb1b74d8d8632ebb1 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 12:18:53 +0100 Subject: Using Ocaml type instead of string to identify resources --- mppa_k1c/PostpassSchedulingOracle.ml | 71 ++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 35 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index a97fda83..49cece02 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -442,7 +442,9 @@ let encode_imm (imm:int64) = else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm (** Resources *) -let resource_names = ["ISSUE"; "TINY"; "LITE"; "FULL"; "LSU"; "MAU"; "BCU"; "TCA"; "AUXR"; "AUXW"; "CRRP"; "CRWL"; "CRWH"; "NOP"] +type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop + +let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop] let rec find_index elt l = match l with @@ -454,99 +456,98 @@ let resource_id resource : int = find_index resource resource_names let resource_bound resource : int = match resource with - | "ISSUE" -> 8 - | "TINY" -> 4 - | "LITE" -> 2 - | "FULL" -> 1 - | "LSU" -> 1 - | "MAU" -> 1 - | "BCU" -> 1 - | "TCA" -> 1 - | "AUXR" -> 1 - | "AUXW" -> 1 - | "CRRP" -> 1 - | "CRWL" -> 1 - | "CRWH" -> 1 - | "NOP" -> 4 - | _ -> raise Not_found + | Rissue -> 8 + | Rtiny -> 4 + | Rlite -> 2 + | Rfull -> 1 + | Rlsu -> 1 + | Rmau -> 1 + | Rbcu -> 1 + | Rtca -> 1 + | Rauxr -> 1 + | Rauxw -> 1 + | Rcrrp -> 1 + | Rcrwl -> 1 + | Rcrwh -> 1 + | Rnop -> 4 let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) (** Reservation tables *) let alu_full : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_lite_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_nop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0 + | Rissue -> 1 | Rnop -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let alu_tiny_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "BCU" -> 1 | _ -> 0 + | Rissue -> 1 | Rbcu -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0 + | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxr_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXR" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let lsu_auxw_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "AUXW" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau : int array = let resmap = fun r -> match r with - | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau_x : int array = let resmap = fun r -> match r with - | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) let mau_y : int array = let resmap = fun r -> match r with - | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0 + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) -- cgit From fadf090fcc33d9d5aabde1cb1f2c5116302427a4 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 6 Feb 2020 14:30:28 +0100 Subject: Fixing maddw and maddd resource tables --- mppa_k1c/PostpassSchedulingOracle.ml | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 49cece02..686979a6 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -550,6 +550,17 @@ let mau_y : int array = let resmap = fun r -> match r with | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 in Array.of_list (List.map resmap resource_names) +let mau_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) (** Real instructions *) @@ -602,10 +613,16 @@ let rec_to_usage r = | Some U27L5 | Some U27L10 -> alu_tiny_x | Some E27U27L10 -> alu_tiny_y | _ -> raise InvalidEncoding) - | Mulw| Maddw | Msbfw -> (match encoding with None -> mau + | Maddw -> (match encoding with None -> mau_auxr + | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x + | _ -> raise InvalidEncoding) + | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr + | Some U27L5 | Some U27L10 -> mau_auxr_x + | Some E27U27L10 -> mau_auxr_y) + | Mulw| Msbfw -> (match encoding with None -> mau | Some U6 | Some S10 | Some U27L5 -> mau_x | _ -> raise InvalidEncoding) - | Muld | Maddd | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau + | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau | Some U27L5 | Some U27L10 -> mau_x | Some E27U27L10 -> mau_y) | Nop -> alu_nop -- cgit From aec490a064af1cdbcc8ac70a9b5a2c882bea6b55 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 16:26:05 +0100 Subject: Moved some theorems --- mppa_k1c/Asmblock.v | 25 +++++++ mppa_k1c/Asmblockgenproof.v | 13 ---- mppa_k1c/Asmblockgenproof0.v | 139 ++++++++++++++++++++----------------- mppa_k1c/PostpassSchedulingproof.v | 37 ---------- 4 files changed, 101 insertions(+), 113 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index 91e5ac89..cce180ac 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -294,6 +294,31 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := end end. + +Theorem builtin_body_nil: + forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. +Proof. + intros. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. + eapply H1; eauto. +Qed. + +Theorem exec_body_app: + forall l l' rs m rs'' m'', + exec_body (l ++ l') rs m = Next rs'' m'' -> + exists rs' m', + exec_body l rs m = Next rs' m' + /\ exec_body l' rs' m' = Next rs'' m''. +Proof. + induction l. + - intros. simpl in H. repeat eexists. auto. + - intros. rewrite <- app_comm_cons in H. simpl in H. + destruct (exec_basic_instr a rs m) eqn:EXEBI. + + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. simpl. rewrite EXEBI. eauto. auto. + + discriminate. +Qed. + (** Position corresponding to a label *) Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index e130df45..220ae08b 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1353,19 +1353,6 @@ Proof. rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. Qed. -Lemma exec_body_pc: - forall l rs1 m1 rs2 m2, - exec_body tge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - Lemma exec_body_control: forall b rs1 m1 rs2 m2 rs3 m3 fn, exec_body tge (body b) rs1 m1 = Next rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index 07c445e2..d2450a9a 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -752,6 +752,82 @@ Proof. intros. destruct H. auto. Qed. +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + Section STRAIGHTLINE. Variable ge: genv. @@ -880,69 +956,6 @@ Qed. (** Linking exec_straight with exec_straight_blocks *) -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Lemma exec_basic_instr_pc: - forall b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - { (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - { (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. - 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - - { (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - { (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - Lemma exec_straight_pc: forall c c' rs1 m1 rs2 m2, exec_straight c rs1 m1 c' rs2 m2 -> diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 867c10c5..cdf8829f 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,43 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Remark builtin_body_nil: - forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. -Proof. - intros. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. - eapply H1; eauto. -Qed. - -Lemma exec_body_app: - forall l l' ge rs m rs'' m'', - exec_body ge (l ++ l') rs m = Next rs'' m'' -> - exists rs' m', - exec_body ge l rs m = Next rs' m' - /\ exec_body ge l' rs' m' = Next rs'' m''. -Proof. - induction l. - - intros. simpl in H. repeat eexists. auto. - - intros. rewrite <- app_comm_cons in H. simpl in H. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI. - + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. simpl. rewrite EXEBI. eauto. auto. - + discriminate. -Qed. - -Lemma exec_body_pc: - forall l ge rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - Lemma next_eq: forall (rs rs': regset) m m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -- cgit From b748b38c8b3a998f018477d7375ae16997318769 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:30:07 +0100 Subject: Removing from Asmblockgenproof0 architecture specific definitions --- mppa_k1c/Asmblock.v | 13 ++++ mppa_k1c/Asmblockdeps.v | 10 +-- mppa_k1c/Asmblockgenproof.v | 2 +- mppa_k1c/Asmblockgenproof0.v | 124 ++---------------------------------- mppa_k1c/Asmblockgenproof1.v | 2 +- mppa_k1c/Asmblockprops.v | 126 +++++++++++++++++++++++++++++++++++++ mppa_k1c/PostpassScheduling.v | 2 +- mppa_k1c/PostpassSchedulingproof.v | 2 +- 8 files changed, 152 insertions(+), 129 deletions(-) create mode 100644 mppa_k1c/Asmblockprops.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index cce180ac..a05d4726 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -33,6 +33,19 @@ Require Import Conventions. Require Import Errors. Require Export Asmvliw. +(* Notations necessary to hook Asmvliw definitions *) +Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs. +Notation regset := Asmvliw.regset. +Notation extcall_arg := Asmvliw.extcall_arg. +Notation extcall_arg_pair := Asmvliw.extcall_arg_pair. +Notation extcall_arguments := Asmvliw.extcall_arguments. +Notation set_res := Asmvliw.set_res. +Notation function := Asmvliw.function. +Notation bblocks := Asmvliw.bblocks. +Notation header := Asmvliw.header. +Notation body := Asmvliw.body. +Notation exit := Asmvliw.exit. +Notation correct := Asmvliw.correct. (** * Auxiliary utilies on basic blocks *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 584f2339..02f9141b 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -7,7 +7,7 @@ Require Import AST. Require Import Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import Values. Require Import Globalenvs. Require Import Memory. @@ -1429,7 +1429,7 @@ Lemma bblock_simu_reduce: forall p1 p2 ge fn, Ge = Genv ge fn -> L.bblock_simu Ge (trans_block p1) (trans_block p2) -> - Asmblockgenproof0.bblock_simu ge fn p1 p2. + Asmblockprops.bblock_simu ge fn p1 p2. Proof. unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. generalize (H2 (trans_state (State rs m))); clear H2. @@ -1787,7 +1787,7 @@ Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. Theorem bblock_simu_test_correct verb p1 p2 : - WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockgenproof0.bblock_simu ge fn p1 p2. + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2. Proof. wlp_simplify. Qed. @@ -1803,7 +1803,7 @@ Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := | None => false end. -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. unfold pure_bblock_simu_test. destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. @@ -1813,7 +1813,7 @@ Qed. Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. -Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2. +Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. Proof. eapply (pure_bblock_simu_test_correct true). Qed. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 220ae08b..1a427112 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -16,7 +16,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. Require Import Axioms. Module MB := Machblock. diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v index d2450a9a..940c6563 100644 --- a/mppa_k1c/Asmblockgenproof0.v +++ b/mppa_k1c/Asmblockgenproof0.v @@ -22,16 +22,10 @@ Require Import Asmblockgen. Require Import Conventions1. Require Import Axioms. Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. Module MB:=Machblock. -Module AB:=Asmvliw. - -Hint Extern 2 (_ <> _) => congruence: asmgen. - -Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - forall rs m, - exec_bblock ge f bb rs m <> Stuck -> - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. +Module AB:=Asmblock. Lemma ireg_of_eq: forall r r', ireg_of r = OK r' -> preg_of r = IR r'. @@ -51,53 +45,6 @@ Proof. destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. Qed. -Lemma preg_of_data: - forall r, data_preg (preg_of r) = true. -Proof. - intros. destruct r; reflexivity. -Qed. -Hint Resolve preg_of_data: asmgen. - -Lemma data_diff: - forall r r', - data_preg r = true -> data_preg r' = false -> r <> r'. -Proof. - congruence. -Qed. -Hint Resolve data_diff: asmgen. - -Lemma preg_of_not_SP: - forall r, preg_of r <> SP. -Proof. - intros. unfold preg_of; destruct r; simpl; congruence. -Qed. - -Lemma preg_of_not_PC: - forall r, preg_of r <> PC. -Proof. - intros. apply data_diff; auto with asmgen. -Qed. - -Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. - -Lemma nextblock_pc: - forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). -Proof. - intros. apply Pregmap.gss. -Qed. - -Lemma nextblock_inv: - forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. -Proof. - intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. -Qed. - -Lemma nextblock_inv1: - forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. -Proof. - intros. apply nextblock_inv. red; intro; subst; discriminate. -Qed. - Lemma undef_regs_other: forall r rl rs, (forall r', In r' rl -> r <> r') -> @@ -294,9 +241,9 @@ Qed. Lemma agree_undef_caller_save_regs: forall ms sp rs, agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (Asmvliw.undef_caller_save_regs rs). + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.undef_caller_save_regs; split. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. - unfold proj_sumbool; rewrite dec_eq_true. auto. - auto. - intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). @@ -752,69 +699,6 @@ Proof. intros. destruct H. auto. Qed. -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Theorem exec_basic_instr_pc: - forall ge b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - { (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - { (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. - 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - - { (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - { (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - Lemma exec_body_pc: forall ge l rs1 m1 rs2 m2, exec_body ge l rs1 m1 = Next rs2 m2 -> diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index c0a05ab3..ecb4629b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -20,7 +20,7 @@ Require Import Coqlib Errors Maps. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op Locations Machblock Conventions. -Require Import Asmblock Asmblockgen Asmblockgenproof0. +Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. Require Import Chunks. (** Decomposition of integer constants. *) diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v new file mode 100644 index 00000000..7f6e33db --- /dev/null +++ b/mppa_k1c/Asmblockprops.v @@ -0,0 +1,126 @@ +(** Common definition and proofs on Asmblock required by various modules *) + +Require Import Coqlib. +Require Import Integers. +Require Import Memory. +Require Import Globalenvs. +Require Import Values. +Require Import Asmblock. + +Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m, + exec_bblock ge f bb rs m <> Stuck -> + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; congruence. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + + +Lemma nextblock_pc: + forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). +Proof. + intros. apply Pregmap.gss. +Qed. + +Lemma nextblock_inv: + forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. +Proof. + intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. +Qed. + +Lemma nextblock_inv1: + forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. +Proof. + intros. apply nextblock_inv. red; intro; subst; discriminate. +Qed. + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. \ No newline at end of file diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 8b6de1e2..31180cea 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -12,7 +12,7 @@ Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. -Require Import Asmblockdeps Asmblockgenproof0. +Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops. Require Peephole. Local Open Scope error_monad_scope. diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index cdf8829f..f1166a38 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -14,7 +14,7 @@ Require Import Coqlib Errors. Require Import Integers Floats AST Linking. Require Import Values Memory Events Globalenvs Smallstep. Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgenproof0. +Require Import Asmblockgenproof0 Asmblockprops. Require Import PostpassScheduling. Require Import Asmblockgenproof. Require Import Axioms. -- cgit From c9ad4b36bb969439d554784f553b7da01e0ba04b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 10 Feb 2020 18:59:02 +0100 Subject: Moving Asmblockgenproof0 to mppa_k1c/lib/ --- mppa_k1c/Asmblockgenproof0.v | 967 --------------------------------------- mppa_k1c/lib/Asmblockgenproof0.v | 967 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 967 insertions(+), 967 deletions(-) delete mode 100644 mppa_k1c/Asmblockgenproof0.v create mode 100644 mppa_k1c/lib/Asmblockgenproof0.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/Asmblockgenproof0.v deleted file mode 100644 index 940c6563..00000000 --- a/mppa_k1c/Asmblockgenproof0.v +++ /dev/null @@ -1,967 +0,0 @@ -(** * "block" version of Asmgenproof0 - - This module is largely adapted from Asmgenproof0.v of the other backends - It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends - It has similar definitions than Asmgenproof0, but adapted to this new structure *) - -Require Import Coqlib. -Require Intv. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -Require Import Asmblockgen. -Require Import Conventions1. -Require Import Axioms. -Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) -Require Import Asmblockprops. - -Module MB:=Machblock. -Module AB:=Asmblock. - -Lemma ireg_of_eq: - forall r r', ireg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold ireg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma freg_of_eq: - forall r r', freg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold freg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -Lemma undef_regs_other: - forall r rl rs, - (forall r', In r' rl -> r <> r') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree ms sp rs -> - (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.undef_regs rl ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite <- agree_sp0. apply H0; auto. - rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. - intros. destruct (In_dec mreg_eq r rl). - rewrite Mach.undef_regs_same; auto. - rewrite Mach.undef_regs_other; auto. rewrite H0; auto. - apply preg_of_data. - rewrite preg_notin_charact. intros; red; intros. elim n. - exploit preg_of_injective; eauto. congruence. -Qed. - -Lemma agree_set_undef_mreg: - forall ms sp rs r v rl rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -Qed. - -Lemma agree_undef_caller_save_regs: - forall ms sp rs, - agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). -Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. -- unfold proj_sumbool; rewrite dec_eq_true. auto. -- auto. -- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -Hypothesis transf_function_len: - forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. - - -Lemma return_address_exists: - forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. destruct (transf_function f) as [tf|] eqn:TF. - + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). - exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). - monadInv TR2. - assert (TL3: is_tail x0 (fn_blocks tf)). - { apply is_tail_trans with tc1; auto. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -Qed. - -End RETADDR_EXISTS. - -(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - within the Asmblock code generated by translating Machblock function [f], - and [tc] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -Proof. - intros. destruct H. auto. -Qed. - -Lemma exec_body_pc: - forall ge l rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_two: - forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -Qed. - -(** Linking exec_straight with exec_straight_blocks *) - -Lemma exec_straight_pc: - forall c c' rs1 m1 rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma regset_same_assign (rs: regset) r: - rs # r <- (rs r) = rs. -Proof. - apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. -Qed. - -Lemma exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. rewrite regset_same_assign. auto. - simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. -Qed. - -(** The following lemmas show that straight-line executions - (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v new file mode 100644 index 00000000..940c6563 --- /dev/null +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -0,0 +1,967 @@ +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. +Require Import Conventions1. +Require Import Axioms. +Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. + +Module MB:=Machblock. +Module AB:=Asmblock. + +Lemma ireg_of_eq: + forall r r', ireg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma freg_of_eq: + forall r r', freg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold freg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree ms sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite Mach.undef_regs_other; auto. rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + +Lemma agree_set_undef_mreg: + forall ms sp rs r v rl rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. +- unfold proj_sumbool; rewrite dec_eq_true. auto. +- auto. +- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. destruct (transf_function f) as [tf|] eqn:TF. + + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + within the Asmblock code generated by translating Machblock function [f], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma regset_same_assign (rs: regset) r: + rs # r <- (rs r) = rs. +Proof. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. rewrite regset_same_assign. auto. + simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. -- cgit From e882ee6daa01579bf717b43b55091c859ed75661 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 11 Feb 2020 11:28:38 +0100 Subject: Moving some arch specific theorems from PSproof to Asmblockprops --- mppa_k1c/Asmblockprops.v | 219 ++++++++++++++++++++++++++++++++++++- mppa_k1c/PostpassSchedulingproof.v | 218 ------------------------------------ 2 files changed, 218 insertions(+), 219 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v index 7f6e33db..3c6ba534 100644 --- a/mppa_k1c/Asmblockprops.v +++ b/mppa_k1c/Asmblockprops.v @@ -6,6 +6,7 @@ Require Import Memory. Require Import Globalenvs. Require Import Values. Require Import Asmblock. +Require Import Axioms. Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := forall rs m, @@ -72,6 +73,8 @@ Ltac Simplif := Ltac Simpl := repeat Simplif. +(* For Asmblockgenproof0 *) + Theorem exec_basic_instr_pc: forall ge b rs1 m1 rs2 m2, exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> @@ -123,4 +126,218 @@ Proof. - destruct rs; try discriminate. inv H1. Simpl. - destruct rd; try discriminate. inv H1; Simpl. - reflexivity. -Qed. \ No newline at end of file +Qed. + +(* For PostpassSchedulingproof *) + +Lemma regset_double_set: + forall r1 r2 (rs: regset) v1 v2, + r1 <> r2 -> + (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). +Proof. + intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). + - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. + - destruct (preg_eq r r2). + + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. + + repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma next_eq: + forall (rs rs': regset) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros; apply f_equal2; auto. +Qed. + +Lemma exec_load_offset_pc_var: + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_reg_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_regxs_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_offset_q_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_q_offset rs m rd ra ofs = Next rs' m' -> + exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. + destruct (gpreg_q_expand rd) as [rd0 rd1]. + (* destruct (ireg_eq rd0 ra); try discriminate. *) + rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + inv H. + destruct (Mem.loadv _ _ _); try discriminate. + inv H1. f_equal. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + reflexivity. +Qed. + +Lemma exec_load_offset_o_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_o_offset rs m rd ra ofs = Next rs' m' -> + exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. +(* + destruct (ireg_eq rd0 ra); try discriminate. + destruct (ireg_eq rd1 ra); try discriminate. + destruct (ireg_eq rd2 ra); try discriminate. +*) + rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + rewrite (regset_double_set PC rd2) by discriminate. + rewrite (regset_double_set PC rd3) by discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_offset_pc_var: + forall t rs m rd ra ofs rs' m' v, + exec_store_offset t rs m rd ra ofs = Next rs' m' -> + exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. + destruct (eval_offset ofs); try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_q_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_q_offset rs m rd ra ofs = Next rs' m' -> + exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (gpreg_q_expand _) as [s0 s1]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. apply next_eq; auto. +Qed. + +Lemma exec_store_o_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_o_offset rs m rd ra ofs = Next rs' m' -> + exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. + unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. + destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_reg_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_reg t rs m rd ra ro = Next rs' m' -> + exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_regxs_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_regxs t rs m rd ra ro = Next rs' m' -> + exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Theorem exec_basic_instr_pc_var: + forall ge i rs m rs' m' v, + exec_basic_instr ge i rs m = Next rs' m' -> + exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. + - unfold exec_arith_instr in *. destruct i; destruct i. + all: try (exploreInst; inv H; apply next_eq; auto; + apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). +(* + (* Some cases treated seperately because exploreInst destructs too much *) + all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) + - destruct i. + + exploreInst; apply exec_load_offset_pc_var; auto. + + exploreInst; apply exec_load_reg_pc_var; auto. + + exploreInst; apply exec_load_regxs_pc_var; auto. + + apply exec_load_offset_q_pc_var; auto. + + apply exec_load_offset_o_pc_var; auto. + - destruct i. + + exploreInst; apply exec_store_offset_pc_var; auto. + + exploreInst; apply exec_store_reg_pc_var; auto. + + exploreInst; apply exec_store_regxs_pc_var; auto. + + apply exec_store_q_offset_pc_var; auto. + + apply exec_store_o_offset_pc_var; auto. + - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.storev _ _ _ _); try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. + rewrite (regset_double_set GPR32 PC); try discriminate. + rewrite (regset_double_set GPR12 PC); try discriminate. + rewrite (regset_double_set FP PC); try discriminate. reflexivity. + - repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.loadv _ _ _); try discriminate. + destruct (rs GPR12); try discriminate. + destruct (Mem.free _ _ _ _); try discriminate. + inv H. apply next_eq; auto. + rewrite (regset_double_set GPR32 PC). + rewrite (regset_double_set GPR12 PC). reflexivity. + all: discriminate. + - destruct rs0; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - destruct rd; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - inv H. apply next_eq; auto. +Qed. + + diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index f1166a38..fbb06c9b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -30,25 +30,6 @@ Proof. intros. eapply match_transform_partial_program; eauto. Qed. -Lemma next_eq: - forall (rs rs': regset) m m', - rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - intros; apply f_equal2; auto. -Qed. - -Lemma regset_double_set: - forall r1 r2 (rs: regset) v1 v2, - r1 <> r2 -> - (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). -Proof. - intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). - - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. - - destruct (preg_eq r r2). - + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. - + repeat (rewrite Pregmap.gso; auto). -Qed. - Lemma regset_double_set_id: forall r (rs: regset) v1 v2, (rs # r <- v1 # r <- v2) = (rs # r <- v2). @@ -58,197 +39,6 @@ Proof. - repeat (rewrite Pregmap.gso); auto. Qed. -Lemma exec_load_offset_pc_var: - forall trap t rs m rd ra ofs rs' m' v, - exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> - exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_reg_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_reg trap t rs m rd ra ro = Next rs' m' -> - exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_regxs_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> - exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_offset_q_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_q_offset rs m rd ra ofs = Next rs' m' -> - exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. - destruct (gpreg_q_expand rd) as [rd0 rd1]. - (* destruct (ireg_eq rd0 ra); try discriminate. *) - rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - inv H. - destruct (Mem.loadv _ _ _); try discriminate. - inv H1. f_equal. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - reflexivity. -Qed. - -Lemma exec_load_offset_o_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_o_offset rs m rd ra ofs = Next rs' m' -> - exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. -(* - destruct (ireg_eq rd0 ra); try discriminate. - destruct (ireg_eq rd1 ra); try discriminate. - destruct (ireg_eq rd2 ra); try discriminate. -*) - rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - rewrite (regset_double_set PC rd2) by discriminate. - rewrite (regset_double_set PC rd3) by discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_store_offset t rs m rd ra ofs = Next rs' m' -> - exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. - destruct (eval_offset ofs); try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_q_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_q_offset rs m rd ra ofs = Next rs' m' -> - exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (gpreg_q_expand _) as [s0 s1]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. apply next_eq; auto. -Qed. - -Lemma exec_store_o_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_o_offset rs m rd ra ofs = Next rs' m' -> - exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. - unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. - destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_reg t rs m rd ra ro = Next rs' m' -> - exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_regxs t rs m rd ra ro = Next rs' m' -> - exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_basic_instr_pc_var: - forall ge i rs m rs' m' v, - exec_basic_instr ge i rs m = Next rs' m' -> - exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. - - unfold exec_arith_instr in *. destruct i; destruct i. - all: try (exploreInst; inv H; apply next_eq; auto; - apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). -(* - (* Some cases treated seperately because exploreInst destructs too much *) - all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) - - destruct i. - + exploreInst; apply exec_load_offset_pc_var; auto. - + exploreInst; apply exec_load_reg_pc_var; auto. - + exploreInst; apply exec_load_regxs_pc_var; auto. - + apply exec_load_offset_q_pc_var; auto. - + apply exec_load_offset_o_pc_var; auto. - - destruct i. - + exploreInst; apply exec_store_offset_pc_var; auto. - + exploreInst; apply exec_store_reg_pc_var; auto. - + exploreInst; apply exec_store_regxs_pc_var; auto. - + apply exec_store_q_offset_pc_var; auto. - + apply exec_store_o_offset_pc_var; auto. - - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.storev _ _ _ _); try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. - rewrite (regset_double_set GPR32 PC); try discriminate. - rewrite (regset_double_set GPR12 PC); try discriminate. - rewrite (regset_double_set FP PC); try discriminate. reflexivity. - - repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.loadv _ _ _); try discriminate. - destruct (rs GPR12); try discriminate. - destruct (Mem.free _ _ _ _); try discriminate. - inv H. apply next_eq; auto. - rewrite (regset_double_set GPR32 PC). - rewrite (regset_double_set GPR12 PC). reflexivity. - all: discriminate. - - destruct rs0; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - destruct rd; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - inv H. apply next_eq; auto. -Qed. - Lemma exec_body_pc_var: forall l ge rs m rs' m' v, exec_body ge l rs m = Next rs' m' -> @@ -745,12 +535,8 @@ Qed. End PRESERVATION_ASMBLOCK. - - - Require Import Asmvliw. - Lemma verified_par_checks_alls_bundles lb x: forall bundle, verify_par lb = OK x -> List.In bundle lb -> verify_par_bblock bundle = OK tt. @@ -761,7 +547,6 @@ Proof. destruct x0; auto. Qed. - Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: verified_schedule_nob bb = OK lb -> List.In bundle lb -> verify_par_bblock bundle = OK tt. @@ -883,9 +668,6 @@ Qed. End PRESERVATION_ASMVLIW. - - - Section PRESERVATION. Variables prog tprog: program. -- cgit From 4f659bb46bb3e2d2c1f297d65e71bb8e66782f79 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 3 Mar 2020 18:13:04 +0100 Subject: forgot k1C --- mppa_k1c/CSE2deps.v | 20 ++++++++ mppa_k1c/CSE2depsproof.v | 127 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+) create mode 100644 mppa_k1c/CSE2deps.v create mode 100644 mppa_k1c/CSE2depsproof.v (limited to 'mppa_k1c') diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v new file mode 100644 index 00000000..8ab9242a --- /dev/null +++ b/mppa_k1c/CSE2deps.v @@ -0,0 +1,20 @@ +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v new file mode 100644 index 00000000..a3811e78 --- /dev/null +++ b/mppa_k1c/CSE2depsproof.v @@ -0,0 +1,127 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE2 CSE2deps. +Require Import Lia. + +Lemma ptrofs_size : + Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. +Proof. + unfold Ptrofs.modulus. + rewrite ptrofs_size. + destruct Archi.ptr64; reflexivity. +Qed. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section MEMORY_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + Variable base : val. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Aindexed ofsw) (base :: nil) = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aindexed ofsr) (base :: nil) = Some addrr. + + Lemma load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + destruct base; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End MEMORY_WRITE. +End SOUNDNESS. + + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Lemma may_overlap_sound: + forall m m' : mem, + forall chunk addr args chunk' addr' args' v a a' rs, + (eval_addressing genv sp addr (rs ## args)) = Some a -> + (eval_addressing genv sp addr' (rs ## args')) = Some a' -> + (may_overlap chunk addr args chunk' addr' args') = false -> + (Mem.storev chunk m a v) = Some m' -> + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. -- cgit From 7b85e3b00e500c5d65cf2df1adeae8ecd7d3e88d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sat, 7 Mar 2020 06:50:50 +0100 Subject: removing warnings on hints in core --- mppa_k1c/Asmblockdeps.v | 6 +++--- mppa_k1c/Asmblockgenproof1.v | 4 ++-- mppa_k1c/PostpassSchedulingproof.v | 2 +- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 2 +- mppa_k1c/abstractbb/ImpSimuTest.v | 14 +++++++------- mppa_k1c/abstractbb/Impure/ImpHCons.v | 4 ++-- mppa_k1c/abstractbb/Parallelizability.v | 8 ++++---- mppa_k1c/abstractbb/SeqSimuTheory.v | 11 ++++------- mppa_k1c/lib/Asmblockgenproof0.v | 4 ++-- mppa_k1c/lib/ForwardSimulationBlock.v | 6 +++--- mppa_k1c/lib/Machblockgenproof.v | 20 ++++++++++---------- 11 files changed, 39 insertions(+), 42 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 02f9141b..bc9f2584 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1005,7 +1005,7 @@ Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: Proof. (* a little tactic to automate reasoning on preg_eq *) -Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. Local Ltac preg_eq_discr r rd := destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); rewrite (assign_diff _ (#rd) (#r) _); auto; @@ -1053,7 +1053,7 @@ Local Ltac preg_eq_discr r rd := preg_eq_discr r rd0. } (* Load Octuple word *) - + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr. + + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. unfold parexec_load_o_offset. destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. rewrite H0, H. @@ -1423,7 +1423,7 @@ Section SECT_BBLOCK_EQUIV. Variable Ge: genv. -Local Hint Resolve trans_state_match. +Local Hint Resolve trans_state_match: core. Lemma bblock_simu_reduce: forall p1 p2 ge fn, diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index ecb4629b..d3c2008f 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -859,7 +859,7 @@ Proof. destruct cmp; discriminate. Qed. -Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct. +Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. Lemma transl_cbranch_correct_1: forall cond args lbl k c m ms b sp rs m' tbb, @@ -1163,7 +1163,7 @@ Proof. split; intros; Simpl. Qed. -Local Hint Resolve Val_cmpu_correct Val_cmplu_correct. +Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. Lemma transl_condimm_int32u_correct: forall cmp rd r1 n k rs m, diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index fbb06c9b..3b123c75 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -567,7 +567,7 @@ Proof. unfold builtin_alone in H0. erewrite H0; eauto. Qed. -Local Hint Resolve verified_schedule_nob_checks_alls_bundles. +Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. Lemma verified_schedule_checks_alls_bundles bb lb bundle: verified_schedule bb = OK lb -> diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index 5c94d435..cf46072f 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -403,7 +403,7 @@ Proof. * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. Qed. -Local Hint Resolve app_fail_allvalid_correct. +Local Hint Resolve app_fail_allvalid_correct: core. Lemma app_fail_correct l pt t1 t2: match_pt t1 pt -> diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index ea55b735..7a77ec15 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -304,12 +304,12 @@ Proof. rewrite <- EQT; eauto. + exploit smem_valid_set_decompose_1; eauto. - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. - Local Hint Resolve smem_valid_set_decompose_1. + Local Hint Resolve smem_valid_set_decompose_1: core. intros; case (R.eq_dec x x0). + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + intros; rewrite !Dict.set_spec_diff; simpl; eauto. Qed. -Local Hint Resolve naive_set_correct. +Local Hint Resolve naive_set_correct: core. Definition equiv_hsmem ge (hd1 hd2: hsmem) := (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) @@ -523,7 +523,7 @@ Lemma hinst_smem_correct i: forall hd hod, WHEN hinst_smem i hd hod ~> hd' THEN forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. Proof. - Local Hint Resolve smem_valid_set_proof. + Local Hint Resolve smem_valid_set_proof: core. induction i; simpl; wlp_simplify; eauto 15 with wlp. Qed. Global Opaque hinst_smem. @@ -563,7 +563,7 @@ Definition bblock_hsmem: bblock -> ?? hsmem Lemma bblock_hsmem_correct p: WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. Proof. - Local Hint Resolve hsmem_empty_correct. + Local Hint Resolve hsmem_empty_correct: core. wlp_simplify. Qed. Global Opaque bblock_hsmem. @@ -775,7 +775,7 @@ Proof. intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. Qed. -Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv. +Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core. Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := DO log <~ count_logger ();; @@ -802,7 +802,7 @@ Obligation 2. wlp_simplify. Qed. -Local Hint Resolve g_bblock_simu_test_correct. +Local Hint Resolve g_bblock_simu_test_correct: core. Theorem bblock_simu_test_correct p1 p2: WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. @@ -1123,7 +1123,7 @@ Definition get {A} (d:t A) (x:R.t): option A Definition set {A} (d:t A) (x:R.t) (v:A): t A := PositiveMap.add x v d. -Local Hint Unfold PositiveMap.E.eq. +Local Hint Unfold PositiveMap.E.eq: core. Lemma set_spec_eq A d x (v: A): get (set d x v) x = Some v. diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v index d8002375..637116cc 100644 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v @@ -95,7 +95,7 @@ Proof. wlp_simplify. Qed. Global Opaque assert_list_incl. -Hint Resolve assert_list_incl_correct. +Hint Resolve assert_list_incl_correct: wlp. End Sets. @@ -165,7 +165,7 @@ Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). Proof. - Local Hint Resolve f_equal2. + Local Hint Resolve f_equal2: core. wlp_simplify. exploit H; eauto. + wlp_simplify. diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 22809095..30904b5d 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -332,7 +332,7 @@ Fixpoint bblock_wframe(p:bblock): list R.t := | i::p' => (inst_wframe i)++(bblock_wframe p') end. -Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm. +Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core. Lemma bblock_wframe_Permutation p p': Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). @@ -620,7 +620,7 @@ Include ParallelizablityChecking L. Section PARALLEL2. Variable ge: genv. -Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame. +Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core. (** Now, refinement of each operation toward parallelizable *) @@ -659,14 +659,14 @@ Fixpoint inst_sframe (i: inst): S.t := | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) end. -Local Hint Resolve exp_sframe_correct. +Local Hint Resolve exp_sframe_correct: core. Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i). Proof. induction i as [|[y e] i']; simpl; auto. Qed. -Local Hint Resolve inst_wsframe_correct inst_sframe_correct. +Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core. Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := match p with diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index 649dd083..e234883f 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -102,9 +102,6 @@ Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := let d':=inst_smem i d d in bblock_smem_rec p' d' end. -(* -Local Hint Resolve smem_eval_empty. -*) Definition bblock_smem: bblock -> smem := fun p => bblock_smem_rec p smem_empty. @@ -124,7 +121,7 @@ Proof. intros d a H; eapply inst_smem_pre_monotonic; eauto. Qed. -Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic. +Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core. Lemma term_eval_exp e (od:smem) m0 old: (forall x, term_eval ge (od x) m0 = Some (old x)) -> @@ -185,7 +182,7 @@ Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). Proof. - Local Hint Resolve inst_smem_Some_correct1. + Local Hint Resolve inst_smem_Some_correct1: core. induction p as [ | i p]; simpl; intros m1 m2 d H. - inversion_clear H; eauto. - intros H0 x0. @@ -299,7 +296,7 @@ Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> pre (bblock_smem_rec p d) ge m0. Proof. - Local Hint Resolve inst_valid. + Local Hint Resolve inst_valid: core. induction p as [ | i p]; simpl; intros m1 d H; auto. intros H0 H1. destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. @@ -326,7 +323,7 @@ Theorem bblock_smem_simu p1 p2: smem_simu (bblock_smem p1) (bblock_smem p2) -> bblock_simu ge p1 p2. Proof. - Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core. intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 940c6563..58455ada 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -414,7 +414,7 @@ Proof. Qed. -Local Hint Resolve code_tail_0 code_tail_S. +Local Hint Resolve code_tail_0 code_tail_S: core. Lemma code_tail_next: forall fn ofs c0, @@ -458,7 +458,7 @@ Proof. omega. Qed. -Local Hint Resolve code_tail_next. +Local Hint Resolve code_tail_next: core. Lemma code_tail_next_int: forall fn ofs bi c, diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v index 39dd2234..224eda0a 100644 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -21,7 +21,7 @@ Section starN_lemma. Variable L: semantics. -Local Hint Resolve starN_refl starN_step Eapp_assoc. +Local Hint Resolve starN_refl starN_step Eapp_assoc: core. Lemma starN_split n s t s': starN (step L) (globalenv L) n s t s' -> @@ -93,7 +93,7 @@ Hypothesis simu_end_block: (** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) -Local Hint Resolve starN_refl starN_step. +Local Hint Resolve starN_refl starN_step: core. Definition follows_in_block (head current: state L1): Prop := dist_end_block head >= dist_end_block current @@ -164,7 +164,7 @@ Inductive is_well_memorized (s s': memostate): Prop := memorized s' = None -> is_well_memorized s s'. -Local Hint Resolve StartBloc MidBloc ExitBloc. +Local Hint Resolve StartBloc MidBloc ExitBloc: core. Definition memoL1 := {| state := memostate; diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 91be5e2e..0de2df52 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -72,7 +72,7 @@ Proof. apply match_states_trans_state. Qed. -Local Hint Resolve match_states_trans_state. +Local Hint Resolve match_states_trans_state: core. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. @@ -284,7 +284,7 @@ Proof. Qed. Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated - parent_sp_preserved. + parent_sp_preserved: core. Definition dist_end_block_code (c: Mach.code) := @@ -299,8 +299,8 @@ Definition dist_end_block (s: Mach.state): nat := | _ => 0 end. -Local Hint Resolve exec_nil_body exec_cons_body. -Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore. +Local Hint Resolve exec_nil_body exec_cons_body: core. +Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core. Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. Proof. @@ -336,7 +336,7 @@ Proof. omega. Qed. -Local Hint Resolve dist_end_block_code_simu_mid_block. +Local Hint Resolve dist_end_block_code_simu_mid_block: core. Lemma size_nonzero c b bl: @@ -392,8 +392,8 @@ destruct i; congruence. Qed. -Local Hint Resolve Mlabel_is_not_cfi. -Local Hint Resolve MBbasic_is_not_cfi. +Local Hint Resolve Mlabel_is_not_cfi: core. +Local Hint Resolve MBbasic_is_not_cfi: core. Lemma add_to_new_block_is_label i: header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. @@ -408,7 +408,7 @@ Proof. + unfold cfi_bblock in H; simpl in H; congruence. Qed. -Local Hint Resolve Mlabel_is_not_basic. +Local Hint Resolve Mlabel_is_not_basic: core. Lemma trans_code_decompose c: forall b bl, is_trans_code c (b::bl) -> @@ -510,8 +510,8 @@ Proof. rewrite Hs2, Hb2; eauto. Qed. -Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit. -Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same. +Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core. +Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core. Lemma match_states_concat_trans_code st f sp c rs m h: -- cgit From 1df2fadbf5ab0687d2aac52f3a83bbe071c25139 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 9 Mar 2020 08:07:04 +0100 Subject: removing some coqc 8.10 warnings --- mppa_k1c/lib/Machblockgen.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index a65b218f..2ba42814 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -105,7 +105,7 @@ Inductive is_end_block: Machblock_inst -> code -> Prop := | End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl) | End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl. -Local Hint Resolve End_empty End_basic End_cfi. +Local Hint Resolve End_empty End_basic End_cfi: core. Inductive is_trans_code: Mach.code -> code -> Prop := | Tr_nil: is_trans_code nil nil @@ -123,7 +123,7 @@ Inductive is_trans_code: Mach.code -> code -> Prop := header bh = nil -> is_trans_code (i::c) (add_basic bi bh::bl). -Local Hint Resolve Tr_nil Tr_end_block. +Local Hint Resolve Tr_nil Tr_end_block: core. Lemma add_to_code_is_trans_code i c bl: is_trans_code c bl -> @@ -145,7 +145,7 @@ Proof. rewrite <- Heqti. eapply End_cfi. congruence. Qed. -Local Hint Resolve add_to_code_is_trans_code. +Local Hint Resolve add_to_code_is_trans_code: core. Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, is_trans_code c2 mbi -> @@ -185,7 +185,7 @@ Proof. exists mbi1. split; congruence. Qed. -Local Hint Resolve trans_code_is_trans_code. +Local Hint Resolve trans_code_is_trans_code: core. Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). Proof. -- cgit From f2a5f59fca7be2c9b31a18e31c66cd21819fce56 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 9 Mar 2020 08:25:59 +0100 Subject: removing more coq8.10 warnings --- mppa_k1c/Asmblockdeps.v | 2 +- mppa_k1c/Asmblockgen.v | 2 ++ mppa_k1c/Asmblockgenproof1.v | 2 ++ mppa_k1c/Asmvliw.v | 6 +++++- 4 files changed, 10 insertions(+), 2 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index bc9f2584..01eda623 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -339,7 +339,7 @@ Proof. } destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. Qed. - + Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := match label_pos lbl 0 (fn_blocks f) with | None => None diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 50637723..36269954 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -28,6 +28,8 @@ Require Import Chunks. Local Open Scope string_scope. Local Open Scope error_monad_scope. +Import PArithCoercions. + (** The code generation functions take advantage of several characteristics of the [Mach] code generated by earlier passes of the compiler, mostly that argument and result registers are of the correct diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index d3c2008f..5b44ddaa 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -23,6 +23,8 @@ Require Import Op Locations Machblock Conventions. Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. Require Import Chunks. +Import PArithCoercions. + (** Decomposition of integer constants. *) Lemma make_immed32_sound: diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index e042d95a..946007c1 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -555,6 +555,8 @@ Inductive ar_instruction : Type := | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) . +Module PArithCoercions. + Coercion PArithR: arith_name_r >-> Funclass. Coercion PArithRR: arith_name_rr >-> Funclass. Coercion PArithRI32: arith_name_ri32 >-> Funclass. @@ -569,6 +571,8 @@ Coercion PArithARR: arith_name_arr >-> Funclass. Coercion PArithARRI32: arith_name_arri32 >-> Funclass. Coercion PArithARRI64: arith_name_arri64 >-> Funclass. +End PArithCoercions. + Inductive basic : Type := | PArith (i: ar_instruction) | PLoad (i: ld_instruction) @@ -1709,7 +1713,7 @@ Proof. Qed. -Local Hint Resolve parexec_bblock_write_in_order. +Local Hint Resolve parexec_bblock_write_in_order: core. Lemma det_parexec_write_in_order f b rs m rs' m': det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'. -- cgit From 4226a49dccaafe0ecd4b591eaab932679712d58b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 9 Mar 2020 14:44:35 +0100 Subject: Duplicate: getting rid of the annoying exception-based code --- mppa_k1c/DuplicateOpcodeHeuristic.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index 690553ce..2ec314c1 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -2,10 +2,8 @@ open Op open Integers -exception HeuristicSucceeded - -let opcode_heuristic code cond ifso ifnot preferred = - let decision = match cond with +let opcode_heuristic code cond ifso ifnot is_loop_header = + match cond with | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with | Clt | Cle -> Some false | Cgt | Cge -> Some true @@ -27,6 +25,3 @@ let opcode_heuristic code cond ifso ifnot preferred = | _ -> None ) | _ -> None - in match decision with - | Some b -> (preferred := b; raise HeuristicSucceeded) - | None -> () -- cgit From 88d3af62f4d0ed5f400c1e8690343a7a9ad15fe3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 05:59:01 +0100 Subject: progress in RA invariants --- mppa_k1c/Asmblockgenproof1.v | 47 ++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 23 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 5b44ddaa..6a3f2389 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1517,21 +1517,21 @@ Opaque Int.eq. - (* Ocast8signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; simpl; Simpl. + repeat split; intros; simpl; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Ocast16signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. - split; intros; Simpl. + repeat split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1542,7 +1542,7 @@ Opaque Int.eq. - (* Oshrxlimm *) econstructor; split. + apply exec_straight_one. simpl. eauto. - + split. + + repeat split. * rewrite Pregmap.gss. subst v. destruct (rs x0); simpl; trivial. @@ -1553,7 +1553,7 @@ Opaque Int.eq. - (* Ocmp *) exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. eauto with asmgen. + exists rs'; repeat split; eauto with asmgen. - (* Osel *) unfold conditional_move in *. @@ -1572,24 +1572,25 @@ Opaque Int.eq. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ2; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x1); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. + all: destruct c. + all: simpl in *. + all: inv EQ2. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x1); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. - (* Oselimm *) unfold conditional_move_imm32 in *. -- cgit From 5e05d4acc53b4b098cb55006b8daa32149d7fba4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 06:16:12 +0100 Subject: more understandabe proofs --- mppa_k1c/Asmblockgenproof1.v | 76 ++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 38 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 6a3f2389..4c29867b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1596,49 +1596,49 @@ Opaque Int.eq. unfold conditional_move_imm32 in *. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ0; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x0); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. - + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. - (* Osellimm *) unfold conditional_move_imm64 in *. destruct c0; simpl in *. - all: - destruct c; simpl in *; inv EQ0; - econstructor; split; try (apply exec_straight_one; constructor); - split; try (simpl; intros; rewrite Pregmap.gso; trivial; assumption); - unfold Val.select; simpl; - unfold cmove, cmoveu; - rewrite Pregmap.gss; - destruct (rs x0); simpl; trivial; - try rewrite int_ltu_to_neq; - try rewrite int64_ltu_to_neq; - try change (Int64.eq Int64.zero Int64.zero) with true; - try destruct Archi.ptr64; - repeat rewrite if_neg; - simpl; - trivial; - try destruct (_ || _); - trivial; - try apply Val.lessdef_normalize. - + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: try (econstructor; split; [idtac | split ]). + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. Qed. (** Memory accesses *) -- cgit From b1b2c6c6442a48c8eb2f7f378e440d8d4311048f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 20 Mar 2020 06:35:43 +0100 Subject: proof clarification --- mppa_k1c/Asmblockgenproof1.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 4c29867b..00df01e3 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1483,6 +1483,8 @@ Proof. destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. Qed. +Ltac splitall := repeat match goal with |- _ /\ _ => split end. + Lemma transl_op_correct: forall op args res k (rs: regset) m v c, transl_op op args res k = OK c -> @@ -1575,7 +1577,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ2. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. @@ -1599,7 +1601,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ0. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. @@ -1623,7 +1625,7 @@ Opaque Int.eq. all: destruct c. all: simpl in *. all: inv EQ0. - all: try (econstructor; split; [idtac | split ]). + all: econstructor; splitall. all: try apply exec_straight_one. all: intros; simpl; trivial. all: unfold Val.select, cmove, cmoveu; simpl. -- cgit From 027c5f9b643c554bef742bf907e725f8ad949429 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 1 Apr 2020 10:35:16 +0200 Subject: Fix cutrewrite deprecated --- mppa_k1c/PostpassSchedulingproof.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'mppa_k1c') diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 3b123c75..8cc7f0ab 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -61,9 +61,9 @@ Proof. - subst. repeat (rewrite Pregmap.gss); auto. destruct v; simpl; auto. rewrite Ptrofs.add_assoc. - cutrewrite (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)); auto. + enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto. unfold Ptrofs.add. - cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto. + enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto. repeat (rewrite Ptrofs.unsigned_repr); auto. - repeat (rewrite Pregmap.gso; auto). Qed. @@ -220,7 +220,8 @@ Proof. destruct (zeq pos 0). + inv H. exists lbb. constructor; auto. + apply IHlbb in H. destruct H as (c & TAIL). exists c. - cutrewrite (pos = pos - size a + size a). apply code_tail_S; auto. + enough (pos = pos - size a + size a) as ->. + apply code_tail_S; auto. omega. Qed. -- cgit