diff options
29 files changed, 4138 insertions, 458 deletions
@@ -133,6 +133,7 @@ BACKEND=\ Mach.v \ Bounds.v Stacklayout.v Stacking.v Stackingproof.v \ Asm.v Asmgen.v Asmgenproof.v Asmaux.v \ + RTLpathSE_simplify.v \ $(BACKENDLIB) SCHEDULING= \ @@ -140,7 +141,7 @@ SCHEDULING= \ RTLpathLivegen.v RTLpathSE_impl.v \ RTLpathproof.v RTLpathSE_theory.v \ RTLpathSchedulerproof.v RTLpath.v \ - RTLpathScheduler.v + RTLpathScheduler.v RTLpathWFcheck.v # C front-end modules (in cfrontend/) diff --git a/aarch64/Asm.v b/aarch64/Asm.v index 5f109224..067d32fb 100644 --- a/aarch64/Asm.v +++ b/aarch64/Asm.v @@ -201,7 +201,7 @@ Inductive instruction: Type := | Pstrx_a (rs: ireg) (a: addressing) (**r store int64 as any64 *) | Pstrb (rs: ireg) (a: addressing) (**r store int8 *) | Pstrh (rs: ireg) (a: addressing) (**r store int16 *) - | Pstpw (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) + | Pstpw (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int32 *) | Pstpx (rs1 rs2: ireg) (chk1 chk2: memory_chunk) (a: addressing) (**r store two int64 *) (** Integer arithmetic, immediate *) | Paddimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r addition *) diff --git a/common/DebugPrint.ml b/common/DebugPrint.ml index 64efe727..5078f727 100644 --- a/common/DebugPrint.ml +++ b/common/DebugPrint.ml @@ -5,7 +5,7 @@ open Registers let debug_flag = ref false let debug fmt = - if !debug_flag then (flush stderr; Printf.eprintf fmt) + if !debug_flag then (flush stderr; flush stdout; Printf.eprintf fmt) else Printf.ifprintf stderr fmt let print_ptree_bool oc pt = diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 9b7b5c4d..4cff3f28 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -105,6 +105,7 @@ let option_fmadd = ref true let option_div_i32 = ref "stsud" let option_div_i64 = ref "stsud" let option_fcoalesce_mem = ref true +let option_fexpanse_rtlcond = ref true let option_fforward_moves = ref false let option_fmove_loop_invariants = ref false let option_fnontrap_loads = ref true diff --git a/driver/Driver.ml b/driver/Driver.ml index c9eacadc..0c5d9cb4 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -444,6 +444,7 @@ let cmdline_actions = @ f_opt "madd" option_fmadd @ f_opt "nontrap-loads" option_fnontrap_loads @ f_opt "coalesce-mem" option_fcoalesce_mem + @ f_opt "expanse-rtlcond" option_fexpanse_rtlcond @ f_opt "all-loads-nontrap" option_all_loads_nontrap @ f_opt "forward-moves" option_fforward_moves (* Code generation options *) diff --git a/filter_peeplog.fish b/filter_peeplog.fish index b7ba1d28..72a0eaf1 100755 --- a/filter_peeplog.fish +++ b/filter_peeplog.fish @@ -1,9 +1,39 @@ -echo "LDP_CONSEC_PEEP_IMM_INC" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC" | wc -l) -echo "LDP_CONSEC_PEEP_IMM_DEC" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC" | wc -l) -echo "LDP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_FORW_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC" | wc -l) -echo "STP_CONSEC_PEEP_IMM_INC" (cat log | ack "STP_CONSEC_PEEP_IMM_INC" | wc -l) -echo "STP_FORW_SPACED_PEEP_IMM_INC" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC" | wc -l) -echo "LDP_BACK_SPACED_PEEP_IMM_DEC" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC" | wc -l) -echo "STP_BACK_SPACED_PEEP_IMM_INC" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC" | wc -l)
\ No newline at end of file +echo "LDP_CONSEC_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64" | wc -l) +echo "\n" +echo "LDP_CONSEC_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_CONSEC_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_CONSEC_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_CONSEC_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_FORW_SPACED_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr32f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_INC_ldr64f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr32f" | wc -l) +echo "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64f" (cat log | ack "LDP_BACK_SPACED_PEEP_IMM_DEC_ldr64f" | wc -l) +echo "\n" +echo "STP_CONSEC_PEEP_IMM_INC_str32" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str32" | wc -l) +echo "STP_CONSEC_PEEP_IMM_INC_str64" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str32" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str64" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str64" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str32" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str32" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str64" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str64" | wc -l) +echo "\n" +echo "STP_CONSEC_PEEP_IMM_INC_str32f" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_CONSEC_PEEP_IMM_INC_str64f" (cat log | ack "STP_CONSEC_PEEP_IMM_INC_str64f" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str32f" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_FORW_SPACED_PEEP_IMM_INC_str64f" (cat log | ack "STP_FORW_SPACED_PEEP_IMM_INC_str64f" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str32f" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str32f" | wc -l) +echo "STP_BACK_SPACED_PEEP_IMM_INC_str64f" (cat log | ack "STP_BACK_SPACED_PEEP_IMM_INC_str64f" | wc -l) diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v index b87d2692..252a9270 100644 --- a/riscV/Asmgen.v +++ b/riscV/Asmgen.v @@ -203,8 +203,22 @@ Definition transl_cond_single (cmp: comparison) (rd: ireg) (fs1 fs2: freg) := | Cle => (Pfles rd fs1 fs2, true) | Cgt => (Pflts rd fs2 fs1, true) | Cge => (Pfles rd fs2 fs1, true) + end. + +Definition apply_bin_r0_r0r0lbl (optR0: option bool) (sem: ireg0 -> ireg0 -> label -> instruction) (r1 r2: ireg0) (lbl: label) := + match optR0 with + | None => sem r1 r2 lbl + | Some true => sem X0 r1 lbl + | Some false => sem r1 X0 lbl + end. + +Definition apply_bin_r0_r0r0 (optR0: option bool) (sem: ireg0 -> ireg0 -> instruction) (r1 r2: ireg0) := + match optR0 with + | None => sem r1 r2 + | Some true => sem X0 r1 + | Some false => sem r1 X0 end. - + Definition transl_cbranch (cond: condition) (args: list mreg) (lbl: label) (k: code) := match cond, args with @@ -259,7 +273,56 @@ Definition transl_cbranch | Cnotcompfs c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_single c X31 r1 r2 in - OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + OK (insn :: (if normal then Pbeqw X31 X0 lbl else Pbnew X31 X0 lbl) :: k) + + | CEbeqw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) + | CEbnew optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) + | CEbequw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbeqw r1 r2 lbl :: k) + | CEbneuw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbnew r1 r2 lbl :: k) + | CEbltw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbltw r1 r2 lbl :: k) + | CEbltuw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbltuw r1 r2 lbl :: k) + | CEbgew optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbgew r1 r2 lbl :: k) + | CEbgeuw optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbgeuw r1 r2 lbl :: k) + | CEbeql optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) + | CEbnel optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) + | CEbequl optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbeql r1 r2 lbl :: k) + | CEbneul optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbnel r1 r2 lbl :: k) + | CEbltl optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbltl r1 r2 lbl :: k) + | CEbltul optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbltul r1 r2 lbl :: k) + | CEbgel optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbgel r1 r2 lbl :: k) + | CEbgeul optR0, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (apply_bin_r0_r0r0lbl optR0 Pbgeul r1 r2 lbl :: k) | _, _ => Error(msg "Asmgen.transl_cond_branch") end. @@ -342,7 +405,7 @@ Definition transl_condimm_int64u (cmp: comparison) (rd: ireg) (r1: ireg) (n: int match cmp with | Clt => sltuimm64 rd r1 n k | _ => loadimm64 X31 n (transl_cond_int64u cmp rd r1 X31 k) - end. + end. Definition transl_cond_op (cond: condition) (rd: ireg) (args: list mreg) (k: code) := @@ -364,13 +427,13 @@ Definition transl_cond_op OK (transl_cond_int64s c rd r1 r2 k) | Ccomplu c, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64u c rd r1 r2 k) + OK (transl_cond_int64u c rd r1 r2 k) | Ccomplimm c n, a1 :: nil => do r1 <- ireg_of a1; OK (transl_condimm_int64s c rd r1 n k) | Ccompluimm c n, a1 :: nil => do r1 <- ireg_of a1; - OK (transl_condimm_int64u c rd r1 n k) + OK (transl_condimm_int64u c rd r1 n k) | Ccompf c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_float c rd r1 r2 in @@ -386,14 +449,14 @@ Definition transl_cond_op | Cnotcompfs c, f1 :: f2 :: nil => do r1 <- freg_of f1; do r2 <- freg_of f2; let (insn, normal) := transl_cond_single c rd r1 r2 in - OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) + OK (insn :: if normal then Pxoriw rd rd Int.one :: k else k) | _, _ => Error(msg "Asmgen.transl_cond_op") - end. + end. (** Translation of the arithmetic operation [r <- op(args)]. The corresponding instructions are prepended to [k]. *) - + Definition transl_op (op: operation) (args: list mreg) (res: mreg) (k: code) := match op, args with @@ -704,6 +767,138 @@ Definition transl_op | Osingleoflongu, a1 :: nil => do rd <- freg_of res; do rs <- ireg_of a1; OK (Pfcvtslu rd rs :: k) + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + | OEseqw optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) + | OEsnew optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) + | OEsequw optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Pseqw rd) rs1 rs2 :: k) + | OEsneuw optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psnew rd) rs1 rs2 :: k) + | OEsltw optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psltw rd) rs1 rs2 :: k) + | OEsltuw optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psltuw rd) rs1 rs2 :: k) + | OEsltiw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiw rd rs n :: k) + | OEsltiuw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiuw rd rs n :: k) + | OExoriw n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pxoriw rd rs n :: k) + | OEluiw n _, a1 :: nil => + do rd <- ireg_of res; + OK (Pluiw rd n :: k) + | OEaddiwr0 n _, a1 :: nil => + do rd <- ireg_of res; + OK (Paddiw rd X0 n :: k) + | OEseql optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) + | OEsnel optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) + | OEsequl optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Pseql rd) rs1 rs2 :: k) + | OEsneul optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psnel rd) rs1 rs2 :: k) + | OEsltl optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psltl rd) rs1 rs2 :: k) + | OEsltul optR0, a1 :: a2 :: nil => + do rd <- ireg_of res; + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (apply_bin_r0_r0r0 optR0 (Psltul rd) rs1 rs2 :: k) + | OEsltil n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltil rd rs n :: k) + | OEsltiul n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Psltiul rd rs n :: k) + | OExoril n, a1 :: nil => + do rd <- ireg_of res; + do rs <- ireg_of a1; + OK (Pxoril rd rs n :: k) + | OEluil n, a1 :: nil => + do rd <- ireg_of res; + OK (Pluil rd n :: k) + | OEaddilr0 n, a1 :: nil => + do rd <- ireg_of res; + OK (Paddil rd X0 n :: k) + | OEloadli n, nil => + do rd <- ireg_of res; + OK (Ploadli rd n :: k) + | OEfeqd, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfeqd rd r1 r2 :: k) + | OEfltd, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfltd rd r1 r2 :: k) + | OEfled, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfled rd r1 r2 :: k) + | OEfeqs, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfeqs rd r1 r2 :: k) + | OEflts, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pflts rd r1 r2 :: k) + | OEfles, f1 :: f2 :: nil => + do rd <- ireg_of res; + do r1 <- freg_of f1; + do r2 <- freg_of f2; + OK (Pfles rd r1 r2 :: k) | Obits_of_single, a1 :: nil => do rd <- ireg_of res; do rs <- freg_of a1; diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v index 8e9f022c..82c1917d 100644 --- a/riscV/Asmgenproof.v +++ b/riscV/Asmgenproof.v @@ -173,7 +173,7 @@ Remark transl_cond_single_nolabel: transl_cond_single c r1 r2 r3 = (insn, normal) -> nolabel insn. Proof. unfold transl_cond_single; intros. destruct c; inv H; exact I. -Qed. + Qed. Remark transl_cbranch_label: forall cond args lbl k c, @@ -211,7 +211,23 @@ Proof. destruct normal; TailNoLabel. - destruct (transl_cond_single c0 X31 x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. - destruct normal; TailNoLabel. + destruct normal; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. +- destruct optR0 as [[]|]; TailNoLabel. Qed. Remark transl_cond_op_label: @@ -238,7 +254,7 @@ Proof. try (eapply tail_nolabel_trans; [apply loadimm32_label | TailNoLabel]). apply opimm32_label; intros; exact I. - destruct c0; simpl; TailNoLabel. -- destruct c0; simpl; TailNoLabel. + - destruct c0; simpl; TailNoLabel. - unfold transl_condimm_int64s. destruct (Int64.eq n Int64.zero). + destruct c0; simpl; TailNoLabel. @@ -254,7 +270,7 @@ Proof. + destruct c0; simpl; TailNoLabel. + destruct c0; simpl; try (eapply tail_nolabel_trans; [apply loadimm64_label | TailNoLabel]). - apply opimm64_label; intros; exact I. + apply opimm64_label; intros; exact I. - destruct (transl_cond_float c0 r x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_float_nolabel; eauto. destruct normal; TailNoLabel. @@ -267,7 +283,7 @@ Proof. - destruct (transl_cond_single c0 r x x0) as [insn normal] eqn:F; inv EQ2. apply tail_nolabel_cons. eapply transl_cond_single_nolabel; eauto. destruct normal; TailNoLabel. -Qed. + Qed. Remark transl_op_label: forall op args r k c, @@ -292,6 +308,18 @@ Opaque Int.eq. - apply opimm64_label; intros; exact I. - destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel. - eapply transl_cond_op_label; eauto. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. +- destruct optR0 as [[]|]; simpl; TailNoLabel. Qed. Remark indexed_memory_access_label: diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 5940802c..1b3a0dbf 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -375,16 +375,16 @@ Proof. rewrite <- Float32.cmp_swap. auto. - simpl. f_equal. f_equal. f_equal. destruct (rs r2), (rs r1); auto. unfold Val.cmpfs, Val.cmpfs_bool. rewrite <- Float32.cmp_swap. auto. -Qed. + Qed. -Remark branch_on_X31: +(* TODO gourdinl UNUSUED ? Remark branch_on_X31: forall normal lbl (rs: regset) m b, rs#X31 = Val.of_bool (eqb normal b) -> exec_instr ge fn (if normal then Pbnew X31 X0 lbl else Pbeqw X31 X0 lbl) rs m = eval_branch fn lbl rs m (Some b). Proof. intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity. -Qed. + Qed.*) Ltac ArgsInv := repeat (match goal with @@ -417,7 +417,7 @@ Proof. { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } clear EVAL MEXT AG. destruct cond; simpl in TRANSL; ArgsInv. -- exists rs, (transl_cbranch_int32s c0 x x0 lbl). + - exists rs, (transl_cbranch_int32s c0 x x0 lbl). intuition auto. constructor. apply transl_cbranch_int32s_correct; auto. - exists rs, (transl_cbranch_int32u c0 x x0 lbl). intuition auto. constructor. apply transl_cbranch_int32u_correct; auto. @@ -492,7 +492,128 @@ Proof. econstructor; econstructor. split. constructor. apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto. split. rewrite V; destruct normal, b; reflexivity. - intros; Simpl. + intros; Simpl. + +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int.eq i Int.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: (Int.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; auto; + simpl in *. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int.eq Int.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int.eq i Int.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: negb (Int.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero32, Op.zero32 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: (Int64.eq i Int64.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: (Int64.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int64.eq Int64.zero i) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + assert (HB: negb (Int64.eq i Int64.zero) = b) by congruence. + rewrite HB; destruct b; simpl; auto. + + destruct (rs x); simpl in *; try congruence. + destruct (rs x0); try congruence. + assert (HB: negb (Int64.eq i i0) = b) by congruence. + rewrite HB; destruct b; simpl; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. +- destruct optR0 as [[]|]; + unfold apply_bin_r0, apply_bin_r0_r0r0lbl in *; + unfold zero64, Op.zero64 in *; + eexists; eexists; eauto; split; constructor; + simpl in *; try rewrite EVAL'; auto. Qed. Lemma transl_cbranch_correct_true: @@ -830,7 +951,7 @@ Proof. + apply DFL. + apply DFL. + apply DFL. -Qed. + Qed. Lemma transl_cond_op_correct: forall cond rd args k c rs m, @@ -858,7 +979,7 @@ Proof. exists rs'; repeat split; eauto. rewrite MKTOT; eauto. + (* cmplu *) exploit transl_cond_int64u_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. + (* cmplimm *) exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. intros (rs' & A & B & C). @@ -866,7 +987,7 @@ Proof. + (* cmpluimm *) exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. + (* cmpf *) destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR. fold (Val.cmpf c0 (rs x) (rs x0)). @@ -923,7 +1044,7 @@ Proof. * econstructor; split. apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto. split; intros; Simpl. -Qed. + Qed. (** Some arithmetic properties. *) @@ -964,136 +1085,189 @@ Proof. Opaque Int.eq. intros until c; intros TR EV. unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -- (* move *) - destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. -- (* intconst *) - exploit loadimm32_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* longconst *) - exploit loadimm64_correct; eauto. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* floatconst *) - destruct (Float.eq_dec n Float.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* singleconst *) - destruct (Float32.eq_dec n Float32.zero). -+ subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -- (* addrsymbol *) - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). - exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. - intros (rs2 & A & B & C). - exists rs2; split. - apply exec_straight_step with rs1 m; auto. - split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). - rewrite Genv.shift_symbol_address. - replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). - exact B. - intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. -+ TranslOpSimpl. -- (* stackoffset *) - exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. auto with asmgen. -- (* cast8signed *) - econstructor; split. + (* move *) + { destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. } + (* intconst *) + { exploit loadimm32_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* longconst *) + { exploit loadimm64_correct; eauto. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* floatconst *) + { destruct (Float.eq_dec n Float.zero). + + subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. } + (* singleconst *) + { destruct (Float32.eq_dec n Float32.zero). + + subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. } + (* addrsymbol *) + { destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). + + set (rs1 := nextinstr (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs k rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. + + TranslOpSimpl. } + (* stackoffset *) + { exploit addptrofs_correct. instantiate (1 := X2); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. } + (* cast8signed *) + { econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. split; intros; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. -- (* cast16signed *) - econstructor; split. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + (* cast16signed *) + { econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. -- (* addimm *) - exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + (* addimm *) + { exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* andimm *) - exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* andimm *) + { exploit (opimm32_correct Pandw Pandiw Val.and); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* orimm *) exploit (opimm32_correct Porw Poriw Val.or); auto. instantiate (1 := x0); eauto with asmgen. + { intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* xorimm *) + { exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm32_correct Pxorw Pxoriw Val.xor); auto. instantiate (1 := x0); eauto with asmgen. - intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* shrximm *) - destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. - { - exploit Val.shrx_shr_3; eauto. intros E; subst v. - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - } - destruct (Int.eq n Int.zero). -+ econstructor; split. apply exec_straight_one. simpl; eauto. auto. - split; intros; Simpl. -+ destruct (Int.eq n Int.one). - * econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). - econstructor; split. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - eapply exec_straight_step. simpl; reflexivity. auto. - apply exec_straight_one. simpl; reflexivity. auto. - split; intros; Simpl. - -- (* longofintu *) - econstructor; split. + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* shrximm *) + { destruct (Val.shrx (rs x0) (Vint n)) eqn:TOTAL; cbn. + { + exploit Val.shrx_shr_3; eauto. intros E; subst v. + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + } + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. } + (* longofintu *) + { econstructor; split. eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto. split; intros; Simpl. destruct (rs x0); auto. simpl. assert (A: Int.ltu (Int.repr 32) Int64.iwordsize' = true) by auto. rewrite A; simpl. rewrite A. apply Val.lessdef_same. f_equal. - rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. -- (* addlimm *) - exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. + rewrite cast32unsigned_from_cast32signed. apply Int64.zero_ext_shru_shl. compute; auto. } + (* addlimm *) + { exploit (opimm64_correct Paddl Paddil Val.addl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* andimm *) - exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* andimm *) + { exploit (opimm64_correct Pandl Pandil Val.andl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* orimm *) - exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* orimm *) + { exploit (opimm64_correct Porl Poril Val.orl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. rewrite B; auto with asmgen. -- (* xorimm *) - exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* xorimm *) + { exploit (opimm64_correct Pxorl Pxoril Val.xorl); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. rewrite B; auto with asmgen. } + (* shrxlimm *) + { destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. + { + exploit Val.shrxl_shrl_3; eauto. intros E; subst v. + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + } + destruct (Int.eq n Int.zero). + + econstructor; split. apply exec_straight_one. simpl; eauto. auto. + split; intros; Simpl. + + destruct (Int.eq n Int.one). + * econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. + + * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n). + econstructor; split. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + eapply exec_straight_step. simpl; reflexivity. auto. + apply exec_straight_one. simpl; reflexivity. auto. + split; intros; Simpl. } + (* cond *) + { exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. eauto with asmgen. } + (* Expanded instructions from RTL *) + 7,8,15,16: + econstructor; split; try apply exec_straight_one; simpl; eauto; + split; intros; Simpl; unfold may_undef_int; try destruct is_long; simpl; + try rewrite Int.add_commut; try rewrite Int64.add_commut; + destruct (rs (preg_of m0)); try discriminate; eauto. + all: destruct optR0 as [[]|]; unfold apply_bin_r0_r0r0, apply_bin_r0; + econstructor; split; try apply exec_straight_one; simpl; eauto; + split; intros; Simpl. + all: destruct (rs x0); auto. + all: destruct (rs x1); auto. exists rs'; split; eauto. rewrite B; auto with asmgen. - (* shrxlimm *) destruct (Val.shrxl (rs x0) (Vint n)) eqn:TOTAL. @@ -1449,6 +1623,3 @@ Proof. Qed. End CONSTRUCTORS. - - - diff --git a/riscV/ExpansionOracle.ml b/riscV/ExpansionOracle.ml new file mode 100644 index 00000000..95a300c5 --- /dev/null +++ b/riscV/ExpansionOracle.ml @@ -0,0 +1,539 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Léo Gourdin UGA, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open RTLpathLivegenaux +open RTLpathCommon +open Datatypes +open Maps +open RTL +open Op +open Asmgen +open DebugPrint +open RTLpath +open! Integers + +let reg = ref 1 + +let node = ref 1 + +let r2p () = Camlcoq.P.of_int !reg + +let n2p () = Camlcoq.P.of_int !node + +let r2pi () = + reg := !reg + 1; + r2p () + +let n2pi () = + node := !node + 1; + n2p () + +type immt = Xoriw | Xoril | Sltiw | Sltiuw | Sltil | Sltiul + +let load_hilo32 a1 dest hi lo succ is_long k = + if Int.eq lo Int.zero then Iop (OEluiw (hi, is_long), [ a1 ], dest, succ) :: k + else + let r = r2pi () in + Iop (OEluiw (hi, is_long), [ a1 ], r, n2pi ()) + :: Iop (Oaddimm lo, [ r ], dest, succ) :: k + +let load_hilo64 a1 dest hi lo succ k = + if Int64.eq lo Int64.zero then Iop (OEluil hi, [ a1 ], dest, succ) :: k + else + let r = r2pi () in + Iop (OEluil hi, [ a1 ], r, n2pi ()) + :: Iop (Oaddlimm lo, [ r ], dest, succ) :: k + +let loadimm32 a1 dest n succ is_long k = + match make_immed32 n with + | Imm32_single imm -> Iop (OEaddiwr0 (imm, is_long), [ a1 ], dest, succ) :: k + | Imm32_pair (hi, lo) -> load_hilo32 a1 dest hi lo succ is_long k + +let loadimm64 a1 dest n succ k = + match make_immed64 n with + | Imm64_single imm -> Iop (OEaddilr0 imm, [ a1 ], dest, succ) :: k + | Imm64_pair (hi, lo) -> load_hilo64 a1 dest hi lo succ k + | Imm64_large imm -> Iop (OEloadli imm, [], dest, succ) :: k + +let get_opimm imm = function + | Xoriw -> OExoriw imm + | Sltiw -> OEsltiw imm + | Sltiuw -> OEsltiuw imm + | Xoril -> OExoril imm + | Sltil -> OEsltil imm + | Sltiul -> OEsltiul imm + +let opimm32 a1 dest n succ is_long k op opimm = + match make_immed32 n with + | Imm32_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm32_pair (hi, lo) -> + let r = r2pi () in + load_hilo32 a1 r hi lo (n2pi ()) is_long + (Iop (op, [ a1; r ], dest, succ) :: k) + +let opimm64 a1 dest n succ k op opimm = + match make_immed64 n with + | Imm64_single imm -> Iop (get_opimm imm opimm, [ a1 ], dest, succ) :: k + | Imm64_pair (hi, lo) -> + let r = r2pi () in + load_hilo64 a1 r hi lo (n2pi ()) (Iop (op, [ a1; r ], dest, succ) :: k) + | Imm64_large imm -> + let r = r2pi () in + Iop (OEloadli imm, [], r, n2pi ()) :: Iop (op, [ a1; r ], dest, succ) :: k + +let xorimm32 a1 dest n succ is_long k = + opimm32 a1 dest n succ is_long k Oxor Xoriw + +let sltimm32 a1 dest n succ is_long k = + opimm32 a1 dest n succ is_long k (OEsltw None) Sltiw + +let sltuimm32 a1 dest n succ is_long k = + opimm32 a1 dest n succ is_long k (OEsltuw None) Sltiuw + +let xorimm64 a1 dest n succ k = opimm64 a1 dest n succ k Oxorl Xoril + +let sltimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltl None) Sltil + +let sltuimm64 a1 dest n succ k = opimm64 a1 dest n succ k (OEsltul None) Sltiul + +let is_inv_cmp = function Cle | Cgt -> true | _ -> false + +let make_optR0 is_x0 is_inv = if is_x0 then Some is_inv else None + +let cbranch_int32s is_x0 cmp a1 a2 info succ1 succ2 k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Icond (CEbeqw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbnew optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgew optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltw optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgew optR0, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int32u is_x0 cmp a1 a2 info succ1 succ2 k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Icond (CEbequw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbneuw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltuw optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgeuw optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltuw optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgeuw optR0, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int64s is_x0 cmp a1 a2 info succ1 succ2 k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Icond (CEbeql optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbnel optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltl optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgel optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltl optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgel optR0, [ a1; a2 ], succ1, succ2, info) :: k + +let cbranch_int64u is_x0 cmp a1 a2 info succ1 succ2 k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Icond (CEbequl optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cne -> Icond (CEbneul optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Clt -> Icond (CEbltul optR0, [ a1; a2 ], succ1, succ2, info) :: k + | Cle -> Icond (CEbgeul optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cgt -> Icond (CEbltul optR0, [ a2; a1 ], succ1, succ2, info) :: k + | Cge -> Icond (CEbgeul optR0, [ a1; a2 ], succ1, succ2, info) :: k + +let cond_int32s is_x0 cmp a1 a2 dest succ k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Iop (OEseqw optR0, [ a1; a2 ], dest, succ) :: k + | Cne -> Iop (OEsnew optR0, [ a1; a2 ], dest, succ) :: k + | Clt -> Iop (OEsltw optR0, [ a1; a2 ], dest, succ) :: k + | Cle -> + let r = r2pi () in + Iop (OEsltw optR0, [ a2; a1 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + | Cgt -> Iop (OEsltw optR0, [ a2; a1 ], dest, succ) :: k + | Cge -> + let r = r2pi () in + Iop (OEsltw optR0, [ a1; a2 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + +let cond_int32u is_x0 cmp a1 a2 dest succ k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Iop (OEsequw optR0, [ a1; a2 ], dest, succ) :: k + | Cne -> Iop (OEsneuw optR0, [ a1; a2 ], dest, succ) :: k + | Clt -> Iop (OEsltuw optR0, [ a1; a2 ], dest, succ) :: k + | Cle -> + let r = r2pi () in + Iop (OEsltuw optR0, [ a2; a1 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + | Cgt -> Iop (OEsltuw optR0, [ a2; a1 ], dest, succ) :: k + | Cge -> + let r = r2pi () in + Iop (OEsltuw optR0, [ a1; a2 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + +let cond_int64s is_x0 cmp a1 a2 dest succ k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Iop (OEseql optR0, [ a1; a2 ], dest, succ) :: k + | Cne -> Iop (OEsnel optR0, [ a1; a2 ], dest, succ) :: k + | Clt -> Iop (OEsltl optR0, [ a1; a2 ], dest, succ) :: k + | Cle -> + let r = r2pi () in + Iop (OEsltl optR0, [ a2; a1 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + | Cgt -> Iop (OEsltl optR0, [ a2; a1 ], dest, succ) :: k + | Cge -> + let r = r2pi () in + Iop (OEsltl optR0, [ a1; a2 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + +let cond_int64u is_x0 cmp a1 a2 dest succ k = + let optR0 = make_optR0 is_x0 (is_inv_cmp cmp) in + match cmp with + | Ceq -> Iop (OEsequl optR0, [ a1; a2 ], dest, succ) :: k + | Cne -> Iop (OEsneul optR0, [ a1; a2 ], dest, succ) :: k + | Clt -> Iop (OEsltul optR0, [ a1; a2 ], dest, succ) :: k + | Cle -> + let r = r2pi () in + Iop (OEsltul optR0, [ a2; a1 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + | Cgt -> Iop (OEsltul optR0, [ a2; a1 ], dest, succ) :: k + | Cge -> + let r = r2pi () in + Iop (OEsltul optR0, [ a1; a2 ], r, n2pi ()) + :: Iop (OExoriw Int.one, [ r ], dest, succ) :: k + +let is_normal_cmp = function Cne -> false | _ -> true + +let cond_float cmp f1 f2 dest succ = + match cmp with + | Ceq -> Iop (OEfeqd, [ f1; f2 ], dest, succ) + | Cne -> Iop (OEfeqd, [ f1; f2 ], dest, succ) + | Clt -> Iop (OEfltd, [ f1; f2 ], dest, succ) + | Cle -> Iop (OEfled, [ f1; f2 ], dest, succ) + | Cgt -> Iop (OEfltd, [ f2; f1 ], dest, succ) + | Cge -> Iop (OEfled, [ f2; f1 ], dest, succ) + +let cond_single cmp f1 f2 dest succ = + match cmp with + | Ceq -> Iop (OEfeqs, [ f1; f2 ], dest, succ) + | Cne -> Iop (OEfeqs, [ f1; f2 ], dest, succ) + | Clt -> Iop (OEflts, [ f1; f2 ], dest, succ) + | Cle -> Iop (OEfles, [ f1; f2 ], dest, succ) + | Cgt -> Iop (OEflts, [ f2; f1 ], dest, succ) + | Cge -> Iop (OEfles, [ f2; f1 ], dest, succ) + +let expanse_cbranchimm_int32s cmp a1 n info succ1 succ2 k = + if Int.eq n Int.zero then cbranch_int32s true cmp a1 a1 info succ1 succ2 k + else + let r = r2pi () in + loadimm32 a1 r n (n2pi ()) false + (cbranch_int32s false cmp a1 r info succ1 succ2 k) + +let expanse_cbranchimm_int32u cmp a1 n info succ1 succ2 k = + if Int.eq n Int.zero then cbranch_int32u true cmp a1 a1 info succ1 succ2 k + else + let r = r2pi () in + loadimm32 a1 r n (n2pi ()) false + (cbranch_int32u false cmp a1 r info succ1 succ2 k) + +let expanse_cbranchimm_int64s cmp a1 n info succ1 succ2 k = + if Int64.eq n Int64.zero then cbranch_int64s true cmp a1 a1 info succ1 succ2 k + else + let r = r2pi () in + loadimm64 a1 r n (n2pi ()) + (cbranch_int64s false cmp a1 r info succ1 succ2 k) + +let expanse_cbranchimm_int64u cmp a1 n info succ1 succ2 k = + if Int64.eq n Int64.zero then cbranch_int64u true cmp a1 a1 info succ1 succ2 k + else + let r = r2pi () in + loadimm64 a1 r n (n2pi ()) + (cbranch_int64u false cmp a1 r info succ1 succ2 k) + +let expanse_condimm_int32s cmp a1 n dest succ k = + if Int.eq n Int.zero then cond_int32s true cmp a1 a1 dest succ k + else + match cmp with + | Ceq | Cne -> + let r = r2pi () in + xorimm32 a1 r n (n2pi ()) false (cond_int32s true cmp r r dest succ k) + | Clt -> sltimm32 a1 dest n succ false k + | Cle -> + if Int.eq n (Int.repr Int.max_signed) then + loadimm32 a1 dest Int.one succ false k + else sltimm32 a1 dest (Int.add n Int.one) succ false k + | _ -> + let r = r2pi () in + loadimm32 a1 r n (n2pi ()) false + (cond_int32s false cmp a1 r dest succ k) + +let expanse_condimm_int32u cmp a1 n dest succ k = + if Int.eq n Int.zero then cond_int32u true cmp a1 a1 dest succ k + else + match cmp with + | Clt -> sltuimm32 a1 dest n succ false k + | _ -> + let r = r2pi () in + loadimm32 a1 r n (n2pi ()) false + (cond_int32u false cmp a1 r dest succ k) + +let expanse_condimm_int64s cmp a1 n dest succ k = + if Int64.eq n Int64.zero then cond_int64s true cmp a1 a1 dest succ k + else + match cmp with + | Ceq | Cne -> + let r = r2pi () in + xorimm64 a1 r n (n2pi ()) (cond_int64s true cmp r r dest succ k) + | Clt -> sltimm64 a1 dest n succ k + | Cle -> + if Int64.eq n (Int64.repr Int64.max_signed) then + loadimm32 a1 dest Int.one succ true k + else sltimm64 a1 dest (Int64.add n Int64.one) succ k + | _ -> + let r = r2pi () in + loadimm64 a1 r n (n2pi ()) (cond_int64s false cmp a1 r dest succ k) + +let expanse_condimm_int64u cmp a1 n dest succ k = + if Int64.eq n Int64.zero then cond_int64u true cmp a1 a1 dest succ k + else + match cmp with + | Clt -> sltuimm64 a1 dest n succ k + | _ -> + let r = r2pi () in + loadimm64 a1 r n (n2pi ()) (cond_int64u false cmp a1 r dest succ k) + +let expanse_cond_fp cnot fn_cond cmp f1 f2 dest succ k = + let normal = is_normal_cmp cmp in + let normal' = if cnot then not normal else normal in + let succ' = if normal' then succ else n2pi () in + let insn = fn_cond cmp f1 f2 dest succ' in + insn + :: (if normal' then k else Iop (OExoriw Int.one, [ dest ], dest, succ) :: k) + +let expanse_cbranch_fp cnot fn_cond cmp f1 f2 info succ1 succ2 k = + let r = r2pi () in + let normal = is_normal_cmp cmp in + let normal' = if cnot then not normal else normal in + let insn = fn_cond cmp f1 f2 r (n2pi ()) in + insn + :: + (if normal' then Icond (CEbnew (Some false), [ r; r ], succ1, succ2, info) + else Icond (CEbeqw (Some false), [ r; r ], succ1, succ2, info)) + :: k + +let get_regindent = function Coq_inr _ -> [] | Coq_inl r -> [ r ] + +let get_regs_inst = function + | Inop _ -> [] + | Iop (_, args, dest, _) -> dest :: args + | Iload (_, _, _, args, dest, _) -> dest :: args + | Istore (_, _, args, src, _) -> src :: args + | Icall (_, t, args, dest, _) -> dest :: (get_regindent t @ args) + | Itailcall (_, t, args) -> get_regindent t @ args + | Ibuiltin (_, args, dest, _) -> + AST.params_of_builtin_res dest @ AST.params_of_builtin_args args + | Icond (_, args, _, _, _) -> args + | Ijumptable (arg, _) -> [ arg ] + | Ireturn (Some r) -> [ r ] + | _ -> [] + +let write_initial_node initial code' new_order = + code' := PTree.set initial (Inop (n2p ())) !code'; + new_order := initial :: !new_order + +let write_pathmap initial esize pm' = + let path = get_some @@ PTree.get initial !pm' in + let npsize = Camlcoq.Nat.of_int (esize + Camlcoq.Nat.to_int path.psize) in + let path' = + { + psize = npsize; + input_regs = path.input_regs; + pre_output_regs = path.pre_output_regs; + output_regs = path.output_regs; + } + in + pm' := PTree.set initial path' !pm' + +let rec write_tree exp current code' new_order = + match exp with + | (Iop (_, _, _, succ) as inst) :: k -> + code' := PTree.set (Camlcoq.P.of_int current) inst !code'; + new_order := Camlcoq.P.of_int current :: !new_order; + write_tree k (current - 1) code' new_order + | (Icond (_, _, succ1, succ2, _) as inst) :: k -> + code' := PTree.set (Camlcoq.P.of_int current) inst !code'; + new_order := Camlcoq.P.of_int current :: !new_order; + write_tree k (current - 1) code' new_order + | [] -> () + | _ -> failwith "ExpansionOracle.write_tree: inconsistent instruction." + +let expanse (sb : superblock) code pm = + (*debug_flag := true;*) + let new_order = ref [] in + let liveins = ref sb.liveins in + let exp = ref [] in + let was_branch = ref false in + let was_exp = ref false in + let code' = ref code in + let pm' = ref pm in + Array.iter + (fun n -> + was_branch := false; + was_exp := false; + let inst = get_some @@ PTree.get n code in + (match inst with + | Iop (Ocmp (Ccomp c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomp\n"; + exp := cond_int32s false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompu\n"; + exp := cond_int32u false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompimm\n"; + exp := expanse_condimm_int32s c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompuimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompuimm\n"; + exp := expanse_condimm_int32u c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompl c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccompl\n"; + exp := cond_int64s false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccomplu c), a1 :: a2 :: nil, dest, succ) -> + debug "Iop/Ccomplu\n"; + exp := cond_int64u false c a1 a2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccomplimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccomplimm\n"; + exp := expanse_condimm_int64s c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompluimm (c, imm)), a1 :: nil, dest, succ) -> + debug "Iop/Ccompluimm\n"; + exp := expanse_condimm_int64u c a1 imm dest succ []; + was_exp := true + | Iop (Ocmp (Ccompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompf\n"; + exp := expanse_cond_fp false cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompf c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompf\n"; + exp := expanse_cond_fp true cond_float c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Ccompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Ccompfs\n"; + exp := expanse_cond_fp false cond_single c f1 f2 dest succ []; + was_exp := true + | Iop (Ocmp (Cnotcompfs c), f1 :: f2 :: nil, dest, succ) -> + debug "Iop/Cnotcompfs\n"; + exp := expanse_cond_fp true cond_single c f1 f2 dest succ []; + was_exp := true + | Icond (Ccomp c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomp\n"; + exp := cbranch_int32s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompu\n"; + exp := cbranch_int32u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompimm\n"; + exp := expanse_cbranchimm_int32s c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompuimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompuimm\n"; + exp := expanse_cbranchimm_int32u c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompl c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompl\n"; + exp := cbranch_int64s false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplu c, a1 :: a2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplu\n"; + exp := cbranch_int64u false c a1 a2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccomplimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccomplimm\n"; + exp := expanse_cbranchimm_int64s c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompluimm (c, imm), a1 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompluimm\n"; + exp := expanse_cbranchimm_int64u c a1 imm info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompf\n"; + exp := expanse_cbranch_fp false cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompf c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompf\n"; + exp := expanse_cbranch_fp true cond_float c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Ccompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Ccompfs\n"; + exp := + expanse_cbranch_fp false cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | Icond (Cnotcompfs c, f1 :: f2 :: nil, succ1, succ2, info) -> + debug "Icond/Cnotcompfs\n"; + exp := expanse_cbranch_fp true cond_single c f1 f2 info succ1 succ2 []; + was_branch := true; + was_exp := true + | _ -> new_order := n :: !new_order); + if !was_exp then ( + node := !node + 1; + (if !was_branch then + let lives = PTree.get n !liveins in + match lives with + | Some lives -> + let new_branch_pc = + Camlcoq.P.of_int (!node - (List.length !exp - 1)) + in + liveins := PTree.set new_branch_pc lives !liveins; + liveins := PTree.remove n !liveins + | _ -> ()); + write_pathmap sb.instructions.(0) (List.length !exp) pm'; + write_initial_node n code' new_order; + write_tree !exp !node code' new_order)) + sb.instructions; + sb.instructions <- Array.of_list (List.rev !new_order); + sb.liveins <- !liveins; + (*debug_flag := false;*) + (!code', !pm') + +let rec find_last_node_reg = function + | [] -> () + | (pc, i) :: k -> + let rec traverse_list var = function + | [] -> () + | e :: t -> + let e' = Camlcoq.P.to_int e in + if e' > !var then var := e'; + traverse_list var t + in + traverse_list node [ pc ]; + traverse_list reg (get_regs_inst i); + find_last_node_reg k diff --git a/riscV/NeedOp.v b/riscV/NeedOp.v index 9e1ad004..4b309f5b 100644 --- a/riscV/NeedOp.v +++ b/riscV/NeedOp.v @@ -87,6 +87,35 @@ 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 + | OEseqw _ => op2 (default nv) + | OEsnew _ => op2 (default nv) + | OEsequw _ => op2 (default nv) + | OEsneuw _ => op2 (default nv) + | OEsltw _ => op2 (default nv) + | OEsltuw _ => op2 (default nv) + | OEsltiw _ => op1 (default nv) + | OEsltiuw _ => op1 (default nv) + | OExoriw _ => op1 (bitwise nv) + | OEluiw _ _ => op1 (default nv) + | OEaddiwr0 _ _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEseql _ => op2 (default nv) + | OEsnel _ => op2 (default nv) + | OEsequl _ => op2 (default nv) + | OEsneul _ => op2 (default nv) + | OEsltl _ => op2 (default nv) + | OEsltul _ => op2 (default nv) + | OEsltil _ => op1 (default nv) + | OEsltiul _ => op1 (default nv) + | OExoril _ => op1 (default nv) + | OEluil _ => op1 (default nv) + | OEaddilr0 _ => op1 (default nv) (* TODO gourdinl modarith impossible? *) + | OEloadli _ => op1 (default nv) + | OEfeqd => op2 (default nv) + | OEfltd => op2 (default nv) + | OEfled => op2 (default nv) + | OEfeqs => op2 (default nv) + | OEflts => op2 (default nv) + | OEfles => op2 (default nv) | Obits_of_single => op1 (default nv) | Obits_of_float => op1 (default nv) | Osingle_of_bits => op1 (default nv) @@ -159,6 +188,7 @@ Proof. - apply shlimm_sound; auto. - apply shrimm_sound; auto. - apply shruimm_sound; auto. +- apply xor_sound; auto with na. - (* selectl *) unfold ExtValues.select01_long. destruct v0; auto with na. @@ -50,7 +50,24 @@ Inductive condition : Type := | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) - | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) + | Cnotcompfs (c: comparison) (**r negation of a floating-point comparison *) + (* Expansed branches *) + | CEbeqw (optR0: option bool) (**r branch-if-equal signed *) + | CEbnew (optR0: option bool) (**r branch-if-not-equal signed *) + | CEbequw (optR0: option bool) (**r branch-if-equal unsigned *) + | CEbneuw (optR0: option bool) (**r branch-if-not-equal unsigned *) + | CEbltw (optR0: option bool) (**r branch-if-less signed *) + | CEbltuw (optR0: option bool) (**r branch-if-less unsigned *) + | CEbgew (optR0: option bool) (**r branch-if-greater-or-equal signed *) + | CEbgeuw (optR0: option bool) (**r branch-if-greater-or-equal unsigned *) + | CEbeql (optR0: option bool) (**r branch-if-equal signed *) + | CEbnel (optR0: option bool) (**r branch-if-not-equal signed *) + | CEbequl (optR0: option bool) (**r branch-if-equal unsigned *) + | CEbneul (optR0: option bool) (**r branch-if-not-equal unsigned *) + | CEbltl (optR0: option bool) (**r branch-if-less signed *) + | CEbltul (optR0: option bool) (**r branch-if-less unsigned *) + | CEbgel (optR0: option bool) (**r branch-if-greater-or-equal signed *) + | CEbgeul (optR0: option bool). (**r branch-if-greater-or-equal unsigned *) (** Arithmetic and logical operations. In the descriptions, [rd] is the result of the operation and [r1], [r2], etc, are the arguments. *) @@ -153,6 +170,37 @@ Inductive operation : Type := | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) (*c Boolean tests: *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + (* Expansed conditions *) + | OEseqw (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) + | OEsnew (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) + | OEsequw (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneuw (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltw (optR0: option bool) (**r set-less-than *) + | OEsltuw (optR0: option bool) (**r set-less-than unsigned *) + | OEsltiw (n: int) (**r set-less-than immediate *) + | OEsltiuw (n: int) (**r set-less-than unsigned immediate *) + | OExoriw (n: int) (**r xor immediate *) + | OEluiw (n: int) (is_long: bool) (**r load upper-immediate *) + | OEaddiwr0 (n: int) (is_long: bool) (**r add immediate *) + | OEseql (optR0: option bool) (**r [rd <- rs1 == rs2] signed *) + | OEsnel (optR0: option bool) (**r [rd <- rs1 != rs2] signed *) + | OEsequl (optR0: option bool) (**r [rd <- rs1 == rs2] unsigned *) + | OEsneul (optR0: option bool) (**r [rd <- rs1 != rs2] unsigned *) + | OEsltl (optR0: option bool) (**r set-less-than *) + | OEsltul (optR0: option bool) (**r set-less-than unsigned *) + | OEsltil (n: int64) (**r set-less-than immediate *) + | OEsltiul (n: int64) (**r set-less-than unsigned immediate *) + | OExoril (n: int64) (**r xor immediate *) + | OEluil (n: int64) (**r load upper-immediate *) + | OEaddilr0 (n: int64) (**r add immediate *) + | OEloadli (n: int64) (**r load an immediate int64 *) + | OEfeqd (**r compare equal *) + | OEfltd (**r compare less-than *) + | OEfled (**r compare less-than/equal *) + | OEfeqs (**r compare equal *) + | OEflts (**r compare less-than *) + | OEfles. (**r compare less-than/equal *) | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) | Obits_of_single | Obits_of_float @@ -172,9 +220,10 @@ Inductive addressing: Type := Definition eq_condition (x y: condition) : {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec; intro. + generalize Int.eq_dec Int64.eq_dec bool_dec; intros. assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. decide equality. + all: destruct optR0, optR1; decide equality. Defined. Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. @@ -185,8 +234,9 @@ Defined. Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; intros. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition bool_dec; intros. decide equality. + all: destruct optR0, optR1; decide equality. Defined. (* Alternate definition: @@ -209,6 +259,34 @@ Global Opaque eq_condition eq_addressing eq_operation. to lists of values. Return [None] when the computation can trigger an error, e.g. integer division by zero. [eval_condition] returns a boolean, [eval_operation] and [eval_addressing] return a value. *) + +Definition zero32 := (Vint Int.zero). +Definition zero64 := (Vlong Int64.zero). + +Definition apply_bin_r0 {B} (optR0: option bool) (sem: val -> val -> B) (v1 v2 vz: val): B := + match optR0 with + | None => sem v1 v2 + | Some true => sem vz v1 + | Some false => sem v1 vz + end. + +Definition may_undef_int (is_long: bool) (sem: val -> val -> val) (v1 vimm vz: val): val := + if negb is_long then + match v1 with + | Vint _ => sem vimm vz + | _ => Vundef + end + else + match v1 with + | Vlong _ => sem vimm vz + | _ => Vundef + end. + +Definition may_undef_luil (v1: val) (n: int64): val := + match v1 with + | Vlong _ => Vlong (Int64.sign_ext 32 (Int64.shl n (Int64.repr 12))) + | _ => Vundef + end. Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := match cond, vl with @@ -224,6 +302,23 @@ Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) + (* Expansed branches *) + | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cne) v1 v2 zero32 + | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero32 + | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cne) v1 v2 zero32 + | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Clt) v1 v2 zero32 + | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpu_bool (Mem.valid_pointer m) Cge) v1 v2 zero32 + | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Ceq) v1 v2 zero64 + | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cne) v1 v2 zero64 + | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Clt) v1 v2 zero64 + | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (Val.cmplu_bool (Mem.valid_pointer m) Cge) v1 v2 zero64 | _, _ => None end. @@ -328,6 +423,36 @@ Definition eval_operation | Osingle_of_bits, v1::nil => Some (ExtValues.single_of_bits v1) | Ofloat_of_bits, v1::nil => Some (ExtValues.float_of_bits v1) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + (* Expansed conditions *) + | OEseqw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Ceq) v1 v2 zero32) + | OEsnew optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Cne) v1 v2 zero32) + | OEsequw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Ceq) v1 v2 zero32) + | OEsneuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Cne) v1 v2 zero32) + | OEsltw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmp Clt) v1 v2 zero32) + | OEsltuw optR0, v1::v2::nil => Some (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) Clt) v1 v2 zero32) + | OEsltiw n, v1::nil => Some (Val.cmp Clt v1 (Vint n)) + | OEsltiuw n, v1::nil => Some (Val.cmpu (Mem.valid_pointer m) Clt v1 (Vint n)) + | OExoriw n, v1::nil => Some (Val.xor v1 (Vint n)) + | OEluiw n is_long, v1::nil => Some (may_undef_int is_long Val.shl v1 (Vint n) (Vint (Int.repr 12))) + | OEaddiwr0 n is_long, v1::nil => Some (may_undef_int is_long Val.add v1 (Vint n) zero32) + | OEseql optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Ceq) v1 v2 zero64)) + | OEsnel optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Cne) v1 v2 zero64)) + | OEsequl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Ceq) v1 v2 zero64)) + | OEsneul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Cne) v1 v2 zero64)) + | OEsltl optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmpl Clt) v1 v2 zero64)) + | OEsltul optR0, v1::v2::nil => Some (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) Clt) v1 v2 zero64)) + | OEsltil n, v1::nil => Some (Val.maketotal (Val.cmpl Clt v1 (Vlong n))) + | OEsltiul n, v1::nil => Some (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Clt v1 (Vlong n))) + | OExoril n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | OEluil n, v1::nil => Some (may_undef_luil v1 n) + | OEaddilr0 n, v1::nil => Some (may_undef_int true Val.addl v1 (Vlong n) zero64) + | OEloadli n, nil => Some (Vlong n) + | OEfeqd, v1::v2::nil => Some (Val.cmpf Ceq v1 v2) + | OEfltd, v1::v2::nil => Some (Val.cmpf Clt v1 v2) + | OEfled, v1::v2::nil => Some (Val.cmpf Cle v1 v2) + | OEfeqs, v1::v2::nil => Some (Val.cmpfs Ceq v1 v2) + | OEflts, v1::v2::nil => Some (Val.cmpfs Clt v1 v2) + | OEfles, v1::v2::nil => Some (Val.cmpfs Cle v1 v2) | Oselectl, vb::vt::vf::nil => Some (Val.normalize (ExtValues.select01_long vb vt vf) Tlong) | _, _ => None end. @@ -388,6 +513,22 @@ Definition type_of_condition (c: condition) : list typ := | Cnotcompf _ => Tfloat :: Tfloat :: nil | Ccompfs _ => Tsingle :: Tsingle :: nil | Cnotcompfs _ => Tsingle :: Tsingle :: nil + | CEbeqw _ => Tint :: Tint :: nil + | CEbnew _ => Tint :: Tint :: nil + | CEbequw _ => Tint :: Tint :: nil + | CEbneuw _ => Tint :: Tint :: nil + | CEbltw _ => Tint :: Tint :: nil + | CEbltuw _ => Tint :: Tint :: nil + | CEbgew _ => Tint :: Tint :: nil + | CEbgeuw _ => Tint :: Tint :: nil + | CEbeql _ => Tlong :: Tlong :: nil + | CEbnel _ => Tlong :: Tlong :: nil + | CEbequl _ => Tlong :: Tlong :: nil + | CEbneul _ => Tlong :: Tlong :: nil + | CEbltl _ => Tlong :: Tlong :: nil + | CEbltul _ => Tlong :: Tlong :: nil + | CEbgel _ => Tlong :: Tlong :: nil + | CEbgeul _ => Tlong :: Tlong :: nil end. Definition type_of_operation (op: operation) : list typ * typ := @@ -485,6 +626,35 @@ Definition type_of_operation (op: operation) : list typ * typ := | Osingleoflong => (Tlong :: nil, Tsingle) | Osingleoflongu => (Tlong :: nil, Tsingle) | Ocmp c => (type_of_condition c, Tint) + | OEseqw _ => (Tint :: Tint :: nil, Tint) + | OEsnew _ => (Tint :: Tint :: nil, Tint) + | OEsequw _ => (Tint :: Tint :: nil, Tint) + | OEsneuw _ => (Tint :: Tint :: nil, Tint) + | OEsltw _ => (Tint :: Tint :: nil, Tint) + | OEsltuw _ => (Tint :: Tint :: nil, Tint) + | OEsltiw _ => (Tint :: nil, Tint) + | OEsltiuw _ => (Tint :: nil, Tint) + | OExoriw _ => (Tint :: nil, Tint) + | OEluiw _ _ => (Tint :: nil, Tint) + | OEaddiwr0 _ _ => (Tint :: nil, Tint) + | OEseql _ => (Tlong :: Tlong :: nil, Tint) + | OEsnel _ => (Tlong :: Tlong :: nil, Tint) + | OEsequl _ => (Tlong :: Tlong :: nil, Tint) + | OEsneul _ => (Tlong :: Tlong :: nil, Tint) + | OEsltl _ => (Tlong :: Tlong :: nil, Tint) + | OEsltul _ => (Tlong :: Tlong :: nil, Tint) + | OEsltil _ => (Tlong :: nil, Tint) + | OEsltiul _ => (Tlong :: nil, Tint) + | OExoril _ => (Tlong :: nil, Tlong) + | OEluil _ => (Tlong :: nil, Tlong) + | OEaddilr0 _ => (Tlong :: nil, Tlong) + | OEloadli _ => (nil, Tlong) + | OEfeqd => (Tfloat :: Tfloat :: nil, Tint) + | OEfltd => (Tfloat :: Tfloat :: nil, Tint) + | OEfled => (Tfloat :: Tfloat :: nil, Tint) + | OEfeqs => (Tsingle :: Tsingle :: nil, Tint) + | OEflts => (Tsingle :: Tsingle :: nil, Tint) + | OEfles => (Tsingle :: Tsingle :: nil, Tint) | Obits_of_single => (Tsingle :: nil, Tint) | Obits_of_float => (Tfloat :: nil, Tlong) | Osingle_of_bits => (Tint :: nil, Tsingle) @@ -696,6 +866,86 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; cbn; trivial. (* cmp *) - destruct (eval_condition cond vl m)... destruct b... + (* OEseqw *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsnew *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsequw *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsneuw *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsltw *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmp; + destruct Val.cmp_bool... all: destruct b... + (* OEsltuw *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpu; + destruct Val.cmpu_bool... all: destruct b... + (* OEsltiw *) + - unfold Val.cmp; destruct Val.cmp_bool... + all: destruct b... + (* OEsltiuw *) + - unfold Val.cmpu; destruct Val.cmpu_bool... destruct b... + (* OExoriw *) + - destruct v0... + (* OEluiw *) + - unfold may_undef_int; + destruct v0, is_long; simpl; trivial; + destruct (Int.ltu _ _); cbn; trivial. + (* OEaddiwr0 *) + - destruct v0, is_long; simpl; trivial. + (* OEseql *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsnel *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsequl *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsneul *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsltl *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmpl; + destruct Val.cmpl_bool... all: destruct b... + (* OEsltul *) + - destruct optR0 as [[]|]; simpl; unfold Val.cmplu; + destruct Val.cmplu_bool... all: destruct b... + (* OEsltil *) + - unfold Val.cmpl; destruct Val.cmpl_bool... + all: destruct b... + (* OEsltiul *) + - unfold Val.cmplu; destruct Val.cmplu_bool... destruct b... + (* OExoril *) + - destruct v0... + (* OEluil *) + - destruct v0; simpl; trivial. + (* OEaddilr0 *) + - destruct v0; simpl; trivial. + (* OEloadli *) + - trivial. + (* OEfeqd *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfltd *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfled *) + - destruct v0; destruct v1; cbn; auto. + destruct Float.cmp; cbn; auto. + (* OEfeqs *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. + (* OEflts *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. + (* OEfles *) + - destruct v0; destruct v1; cbn; auto. + destruct Float32.cmp; cbn; auto. (* Bits_of_single, float *) - destruct v0; cbn; trivial. - destruct v0; cbn; trivial. @@ -777,6 +1027,22 @@ Definition negate_condition (cond: condition): condition := | Cnotcompf c => Ccompf c | Ccompfs c => Cnotcompfs c | Cnotcompfs c => Ccompfs c + | CEbeqw optR0 => CEbnew optR0 + | CEbnew optR0 => CEbeqw optR0 + | CEbequw optR0 => CEbneuw optR0 + | CEbneuw optR0 => CEbequw optR0 + | CEbltw optR0 => CEbgew optR0 + | CEbltuw optR0 => CEbgeuw optR0 + | CEbgew optR0 => CEbltw optR0 + | CEbgeuw optR0 => CEbltuw optR0 + | CEbeql optR0 => CEbnel optR0 + | CEbnel optR0 => CEbeql optR0 + | CEbequl optR0 => CEbneul optR0 + | CEbneul optR0 => CEbequl optR0 + | CEbltl optR0 => CEbgel optR0 + | CEbltul optR0 => CEbgeul optR0 + | CEbgel optR0 => CEbltl optR0 + | CEbgeul optR0 => CEbltul optR0 end. Lemma eval_negate_condition: @@ -796,6 +1062,39 @@ Proof. repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. repeat (destruct vl; auto). repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. + + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmp_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpu_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Cne) with (negate_comparison Ceq) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Ceq) with (negate_comparison Cne) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Cge) with (negate_comparison Clt) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmplu_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmpl_bool. + repeat (destruct vl; auto); replace (Clt) with (negate_comparison Cge) by auto; destruct optR0 as [[]|]; + apply Val.negate_cmplu_bool. Qed. (** Shifting stack-relative references. This is used in [Stacking]. *) @@ -892,12 +1191,28 @@ Definition cond_depends_on_memory (cond : condition) : bool := | Ccompuimm _ _ => negb Archi.ptr64 | Ccomplu _ => Archi.ptr64 | Ccompluimm _ _ => Archi.ptr64 + | CEbequw _ => negb Archi.ptr64 + | CEbneuw _ => negb Archi.ptr64 + | CEbltuw _ => negb Archi.ptr64 + | CEbgeuw _ => negb Archi.ptr64 + | CEbequl _ => Archi.ptr64 + | CEbneul _ => Archi.ptr64 + | CEbltul _ => Archi.ptr64 + | CEbgeul _ => Archi.ptr64 | _ => false end. Definition op_depends_on_memory (op: operation) : bool := match op with | Ocmp cmp => cond_depends_on_memory cmp + | OEsequw _ => negb Archi.ptr64 + | OEsneuw _ => negb Archi.ptr64 + | OEsltiuw _ => negb Archi.ptr64 + | OEsltuw _ => negb Archi.ptr64 + | OEsequl _ => Archi.ptr64 + | OEsneul _ => Archi.ptr64 + | OEsltul _ => Archi.ptr64 + | OEsltiul _ => Archi.ptr64 | _ => false end. @@ -921,6 +1236,11 @@ Proof. intros until m2. destruct op; simpl; try congruence. intro DEPEND. f_equal. f_equal. apply cond_depends_on_memory_correct; trivial. + all: intros; repeat (destruct args; auto); + unfold Val.cmpu, Val.cmpu_bool, Val.cmplu, Val.cmplu_bool; + try destruct optR0 as [[]|]; simpl; + destruct v; try destruct v0; simpl; auto; + try apply negb_false_iff in H; try rewrite H; auto. Qed. Lemma cond_valid_pointer_eq: @@ -930,7 +1250,9 @@ Lemma cond_valid_pointer_eq: Proof. intros until m2. intro MEM. destruct cond eqn:COND; simpl; try congruence. all: repeat (destruct args; simpl; try congruence); - erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + try destruct optR0 as [[]|]; simpl; + try destruct v, v0; try rewrite !MEM; auto; + try erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. Lemma op_valid_pointer_eq: @@ -939,8 +1261,11 @@ Lemma op_valid_pointer_eq: eval_operation ge sp op args m1 = eval_operation ge sp op args m2. Proof. intros until m2. destruct op; simpl; try congruence. - intros MEM; destruct cond; repeat (destruct args; simpl; try congruence); - erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. + intro MEM; erewrite cond_valid_pointer_eq; eauto. + all: intros MEM; repeat (destruct args; simpl; try congruence); + try destruct optR0 as [[]|]; simpl; try destruct v, v0; try rewrite !MEM; auto; + unfold Val.cmpu, Val.cmplu; + erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto. Qed. (** Global variables mentioned in an operation or addressing mode *) @@ -1047,6 +1372,88 @@ Ltac InvInject := | _ => idtac end. +Lemma eval_cmpu_bool_inj': forall b c v v' v0 v0', + Val.inject f v v' -> + Val.inject f v0 v0' -> + Val.cmpu_bool (Mem.valid_pointer m1) c v v0 = Some b -> + Val.cmpu_bool (Mem.valid_pointer m2) c v' v0' = Some b. +Proof. + intros. + eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +Qed. + +Lemma eval_cmpu_bool_inj: forall c v v' v0 v'0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.cmpu (Mem.valid_pointer m1) c v v0) + (Val.cmpu (Mem.valid_pointer m2) c v' v'0). +Proof. + intros until v'0. intros HV1 HV2. + unfold Val.cmpu; + destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto. + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmpu_bool_inj_opt: forall c v v' v0 v'0 optR0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m1) c) v v0 zero32) + (apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m2) c) v' v'0 zero32). +Proof. + intros until optR0. intros HV1 HV2. + destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmpu; + destruct (Val.cmpu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; + assert (HVI: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int. + + exploit eval_cmpu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmpu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmplu_bool_inj': forall b c v v' v0 v0', + Val.inject f v v' -> + Val.inject f v0 v0' -> + Val.cmplu_bool (Mem.valid_pointer m1) c v v0 = Some b -> + Val.cmplu_bool (Mem.valid_pointer m2) c v' v0' = Some b. +Proof. + intros. + eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +Qed. + +Lemma eval_cmplu_bool_inj: forall c v v' v0 v'0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.maketotal (Val.cmplu (Mem.valid_pointer m1) c v v0)) + (Val.maketotal (Val.cmplu (Mem.valid_pointer m2) c v' v'0)). +Proof. + intros until v'0. intros HV1 HV2. + unfold Val.cmplu; + destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto. + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + +Lemma eval_cmplu_bool_inj_opt: forall c v v' v0 v'0 optR0, + Val.inject f v v' -> + Val.inject f v0 v'0 -> + Val.inject f (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m1) c) v v0 zero64)) + (Val.maketotal (apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m2) c) v' v'0 zero64)). +Proof. + intros until optR0. intros HV1 HV2. + destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmplu; + destruct (Val.cmplu_bool (Mem.valid_pointer m1) c _ _) eqn:?; eauto; + assert (HVI: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long. + + exploit eval_cmplu_bool_inj'. eapply HVI. eapply HV1. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HVI. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. + + exploit eval_cmplu_bool_inj'. eapply HV1. eapply HV2. eapply Heqo. + intros EQ; rewrite EQ; destruct b; simpl; constructor; eauto. +Qed. + Lemma eval_condition_inj: forall cond vl1 vl2 b, Val.inject_list f vl1 vl2 -> @@ -1054,6 +1461,9 @@ Lemma eval_condition_inj: eval_condition cond vl2 m2 = Some b. Proof. intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + all: assert (HVI32: Val.inject f (Vint Int.zero) (Vint Int.zero)) by apply Val.inject_int; + assert (HVI64: Val.inject f (Vlong Int64.zero) (Vlong Int64.zero)) by apply Val.inject_long; + try unfold zero32, zero64. - inv H3; inv H2; simpl in H0; inv H0; auto. - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. - inv H3; simpl in H0; inv H0; auto. @@ -1066,6 +1476,38 @@ Proof. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. - inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR0 as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR0 as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmpu_bool_inj'; eauto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR0 as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmplu_bool_inj'; eauto. +- destruct optR0 as [[]|]; simpl; + inv H3; inv H2; simpl in H0; inv H0; auto. +- destruct optR0 as [[]|]; unfold apply_bin_r0 in *; + eapply eval_cmplu_bool_inj'; eauto. Qed. Ltac TrivialExists := @@ -1274,6 +1716,86 @@ Proof. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. destruct b; simpl; constructor. simpl; constructor. + (* OEseqw *) + - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsnew *) + - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsequw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsneuw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsltw *) + - destruct optR0 as [[]|]; simpl; unfold zero32, Val.cmp; + inv H4; inv H2; simpl; try destruct (Int.lt _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsltuw *) + - apply eval_cmpu_bool_inj_opt; auto. + (* OEsltiw *) + - inv H4; simpl; cbn; auto; try destruct (Int.lt _ _); apply Val.inject_int. + (* OEsltiuw *) + - apply eval_cmpu_bool_inj; auto. + (* OExoriw *) + - inv H4; simpl; auto. + (* OEluiw *) + - unfold may_undef_int; + destruct is_long; + inv H4; simpl; auto; + destruct (Int.ltu _ _); auto. + (* OEaddiwr0 *) + - unfold may_undef_int; + destruct is_long; + inv H4; simpl; auto. + (* OEseql *) + - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsnel *) + - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.eq _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsequl *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsneul *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsltl *) + - destruct optR0 as [[]|]; simpl; unfold zero64, Val.cmpl; + inv H4; inv H2; simpl; try destruct (Int64.lt _ _); simpl; cbn; auto; + try apply Val.inject_int. + (* OEsltul *) + - apply eval_cmplu_bool_inj_opt; auto. + (* OEsltil *) + - inv H4; simpl; cbn; auto; try destruct (Int64.lt _ _); apply Val.inject_int. + (* OEsltiul *) + - apply eval_cmplu_bool_inj; auto. + (* OExoril *) + - inv H4; simpl; auto. + (* OEluil *) + - inv H4; simpl; auto. + (* OEaddilr0 *) + - unfold may_undef_int; + inv H4; simpl; auto. + (* OEfeqd *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfltd *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfled *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfeqs *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEflts *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. + (* OEfles *) + - inv H4; inv H2; cbn; simpl; auto. + destruct Float32.cmp; unfold Vtrue, Vfalse; cbn; auto. (* Bits_of_single, double *) - inv H4; simpl; auto. - inv H4; simpl; auto. @@ -1542,4 +2064,4 @@ Definition builtin_arg_ok match ba with | (BA _ | BA_splitlong (BA _) (BA _)) => true | _ => builtin_arg_ok_1 ba c - end. + end. diff --git a/riscV/OpWeights.ml b/riscV/OpWeights.ml index 2b0496fc..35ae81e6 100644 --- a/riscV/OpWeights.ml +++ b/riscV/OpWeights.ml @@ -56,7 +56,23 @@ module Rocket = | Ccompl _ | Ccomplu _ | Ccomplimm _ - | Ccompluimm _ -> 1 + | Ccompluimm _ + | CEbeqw _ + | CEbnew _ + | CEbequw _ + | CEbneuw _ + | CEbltw _ + | CEbltuw _ + | CEbgew _ + | CEbgeuw _ + | CEbeql _ + | CEbnel _ + | CEbequl _ + | CEbneul _ + | CEbltl _ + | CEbltul _ + | CEbgel _ + | CEbgeul _ -> 1 | Ccompf _ | Cnotcompf _ -> 6 | Ccompfs _ diff --git a/riscV/PrintOp.ml b/riscV/PrintOp.ml index 7e78283e..84380251 100644 --- a/riscV/PrintOp.ml +++ b/riscV/PrintOp.ml @@ -30,6 +30,11 @@ let comparison_name = function | Cgt -> ">" | Cge -> ">=" +let get_optR0_s c reg pp r1 r2 = function + | None -> fprintf pp "(%a %s %a)" reg r1 (comparison_name c) reg r2 + | Some true -> fprintf pp "(X0 %s %a)" (comparison_name c) reg r1 + | Some false -> fprintf pp "(%a %s X0)" reg r1 (comparison_name c) + let print_condition reg pp = function | (Ccomp c, [r1;r2]) -> fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 @@ -55,6 +60,38 @@ let print_condition reg pp = function fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 | (Cnotcompfs c, [r1;r2]) -> fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 + | (CEbeqw optR0, [r1;r2]) -> + fprintf pp "CEbeqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | (CEbnew optR0, [r1;r2]) -> + fprintf pp "CEbnew"; (get_optR0_s Cne reg pp r1 r2 optR0) + | (CEbequw optR0, [r1;r2]) -> + fprintf pp "CEbequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | (CEbneuw optR0, [r1;r2]) -> + fprintf pp "CEbneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) + | (CEbltw optR0, [r1;r2]) -> + fprintf pp "CEbltw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | (CEbltuw optR0, [r1;r2]) -> + fprintf pp "CEbltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | (CEbgew optR0, [r1;r2]) -> + fprintf pp "CEbgew"; (get_optR0_s Cge reg pp r1 r2 optR0) + | (CEbgeuw optR0, [r1;r2]) -> + fprintf pp "CEbgeuw"; (get_optR0_s Cge reg pp r1 r2 optR0) + | (CEbeql optR0, [r1;r2]) -> + fprintf pp "CEbeql"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | (CEbnel optR0, [r1;r2]) -> + fprintf pp "CEbnel"; (get_optR0_s Cne reg pp r1 r2 optR0) + | (CEbequl optR0, [r1;r2]) -> + fprintf pp "CEbequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | (CEbneul optR0, [r1;r2]) -> + fprintf pp "CEbneul"; (get_optR0_s Cne reg pp r1 r2 optR0) + | (CEbltl optR0, [r1;r2]) -> + fprintf pp "CEbltl"; (get_optR0_s Clt reg pp r1 r2 optR0) + | (CEbltul optR0, [r1;r2]) -> + fprintf pp "CEbltul"; (get_optR0_s Clt reg pp r1 r2 optR0) + | (CEbgel optR0, [r1;r2]) -> + fprintf pp "CEbgel"; (get_optR0_s Cge reg pp r1 r2 optR0) + | (CEbgeul optR0, [r1;r2]) -> + fprintf pp "CEbgeul"; (get_optR0_s Cge reg pp r1 r2 optR0) | _ -> fprintf pp "<bad condition>" @@ -156,6 +193,35 @@ 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) + | OEseqw optR0, [r1;r2] -> fprintf pp "OEseqw"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | OEsnew optR0, [r1;r2] -> fprintf pp "OEsnew"; (get_optR0_s Cne reg pp r1 r2 optR0) + | OEsequw optR0, [r1;r2] -> fprintf pp "OEsequw"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | OEsneuw optR0, [r1;r2] -> fprintf pp "OEsneuw"; (get_optR0_s Cne reg pp r1 r2 optR0) + | OEsltw optR0, [r1;r2] -> fprintf pp "OEsltw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEsltuw optR0, [r1;r2] -> fprintf pp "OEsltuw"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEsltiw n, [r1] -> fprintf pp "OEsltiw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEsltiuw n, [r1] -> fprintf pp "OEsltiuw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OExoriw n, [r1] -> fprintf pp "OExoriw(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEluiw (n, _), _ -> fprintf pp "OEluiw(%ld)" (camlint_of_coqint n) + | OEaddiwr0 (n, _), _ -> fprintf pp "OEaddiwr0(%ld,X0)" (camlint_of_coqint n) + | OEseql optR0, [r1;r2] -> fprintf pp "OEseql"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | OEsnel optR0, [r1;r2] -> fprintf pp "OEsnel"; (get_optR0_s Cne reg pp r1 r2 optR0) + | OEsequl optR0, [r1;r2] -> fprintf pp "OEsequl"; (get_optR0_s Ceq reg pp r1 r2 optR0) + | OEsneul optR0, [r1;r2] -> fprintf pp "OEsneul"; (get_optR0_s Cne reg pp r1 r2 optR0) + | OEsltl optR0, [r1;r2] -> fprintf pp "OEsltl"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEsltul optR0, [r1;r2] -> fprintf pp "OEsltul"; (get_optR0_s Clt reg pp r1 r2 optR0) + | OEsltil n, [r1] -> fprintf pp "OEsltil(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEsltiul n, [r1] -> fprintf pp "OEsltiul(%a,%ld)" reg r1 (camlint_of_coqint n) + | OExoril n, [r1] -> fprintf pp "OExoril(%a,%ld)" reg r1 (camlint_of_coqint n) + | OEluil n, _ -> fprintf pp "OEluil(%ld)" (camlint_of_coqint n) + | OEaddilr0 n, _ -> fprintf pp "OEaddilr0(%ld,X0)" (camlint_of_coqint n) + | OEloadli n, _ -> fprintf pp "OEloadli(%ld)" (camlint_of_coqint n) + | OEfeqd, [r1;r2] -> fprintf pp "OEfeqd(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 + | OEfltd, [r1;r2] -> fprintf pp "OEfltd(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 + | OEfled, [r1;r2] -> fprintf pp "OEfled(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 + | OEfeqs, [r1;r2] -> fprintf pp "OEfeqs(%a,%s,%a)" reg r1 (comparison_name Ceq) reg r2 + | OEflts, [r1;r2] -> fprintf pp "OEflts(%a,%s,%a)" reg r1 (comparison_name Clt) reg r2 + | OEfles, [r1;r2] -> fprintf pp "OEfles(%a,%s,%a)" reg r1 (comparison_name Cle) reg r2 | Obits_of_single, [r1] -> fprintf pp "bits_of_single(%a)" reg r1 | Obits_of_float, [r1] -> fprintf pp "bits_of_float(%a)" reg r1 | Osingle_of_bits, [r1] -> fprintf pp "single_of_bits(%a)" reg r1 diff --git a/riscV/RTLpathSE_simplify.v b/riscV/RTLpathSE_simplify.v new file mode 100644 index 00000000..6a0297e9 --- /dev/null +++ b/riscV/RTLpathSE_simplify.v @@ -0,0 +1,1323 @@ +Require Import Coqlib Floats Values Memory. +Require Import Integers. +Require Import Op Registers. +Require Import RTLpathSE_theory. +Require Import RTLpathSE_simu_specs. +Require Import Asmgen Asmgenproof1. +Require Import Lia. + +(** Useful functions for conditions/branches expansion *) + +Definition is_inv_cmp_int (cmp: comparison) : bool := + match cmp with | Cle | Cgt => true | _ => false end. + +Definition is_inv_cmp_float (cmp: comparison) : bool := + match cmp with | Cge | Cgt => true | _ => false end. + +Definition make_optR0 (is_x0 is_inv: bool) : option bool := + if is_x0 then Some is_inv else None. + +(** Functions to manage lists of "fake" values *) + +Definition make_lhsv_cmp (is_inv: bool) (hv1 hv2: hsval) : list_hsval := + let (hvfirst, hvsec) := if is_inv then (hv1, hv2) else (hv2, hv1) in + let lhsv := fScons hvfirst fSnil in + fScons hvsec lhsv. + +Definition make_lhsv_single (hvs: hsval) : list_hsval := + fScons hvs fSnil. + +(** Expansion functions *) + +(* Immediate loads *) + +Definition load_hilo32 (hv1: hsval) (hi lo: int) (is_long: bool) := + let hl := make_lhsv_single hv1 in + if Int.eq lo Int.zero then + fSop (OEluiw hi is_long) hl + else + let hvs := fSop (OEluiw hi is_long) hl in + let hl' := make_lhsv_single hvs in + fSop (Oaddimm lo) hl'. + +Definition load_hilo64 (hv1: hsval) (hi lo: int64) := + let hl := make_lhsv_single hv1 in + if Int64.eq lo Int64.zero then + fSop (OEluil hi) hl + else + let hvs := fSop (OEluil hi) hl in + let hl := make_lhsv_single hvs in + fSop (Oaddlimm lo) hl. + +Definition loadimm32 (hv1: hsval) (n: int) (is_long: bool) := + match make_immed32 n with + | Imm32_single imm => + let hl := make_lhsv_single hv1 in + fSop (OEaddiwr0 imm is_long) hl + | Imm32_pair hi lo => load_hilo32 hv1 hi lo is_long + end. + +Definition loadimm64 (hv1: hsval) (n: int64) := + match make_immed64 n with + | Imm64_single imm => + let hl := make_lhsv_single hv1 in + fSop (OEaddilr0 imm) hl + | Imm64_pair hi lo => load_hilo64 hv1 hi lo + | Imm64_large imm => fSop (OEloadli imm) fSnil + end. + +Definition opimm32 (hv1: hsval) (n: int) (op: operation) (opimm: int -> operation) (is_long: bool) := + match make_immed32 n with + | Imm32_single imm => + let hl := make_lhsv_single hv1 in + fSop (opimm imm) hl + | Imm32_pair hi lo => + let hvs := load_hilo32 hv1 hi lo is_long in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + end. + +Definition opimm64 (hv1: hsval) (n: int64) (op: operation) (opimm: int64 -> operation) := + match make_immed64 n with + | Imm64_single imm => + let hl := make_lhsv_single hv1 in + fSop (opimm imm) hl + | Imm64_pair hi lo => + let hvs := load_hilo64 hv1 hi lo in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + | Imm64_large imm => + let hvs := fSop (OEloadli imm) fSnil in + let hl := make_lhsv_cmp false hv1 hvs in + fSop op hl + end. + +Definition xorimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n Oxor OExoriw is_long. +Definition sltimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltw None) OEsltiw is_long. +Definition sltuimm32 (hv1: hsval) (n: int) (is_long: bool) := opimm32 hv1 n (OEsltuw None) OEsltiuw is_long. +Definition xorimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n Oxorl OExoril. +Definition sltimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltl None) OEsltil. +Definition sltuimm64 (hv1: hsval) (n: int64) := opimm64 hv1 n (OEsltul None) OEsltiul. + +(* Comparisons intructions *) + +Definition cond_int32s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := + match cmp with + | Ceq => fSop (OEseqw optR0) lhsv + | Cne => fSop (OEsnew optR0) lhsv + | Clt | Cgt => fSop (OEsltw optR0) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltw optR0) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int32u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := + match cmp with + | Ceq => fSop (OEsequw optR0) lhsv + | Cne => fSop (OEsneuw optR0) lhsv + | Clt | Cgt => fSop (OEsltuw optR0) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltuw optR0) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int64s (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := + match cmp with + | Ceq => fSop (OEseql optR0) lhsv + | Cne => fSop (OEsnel optR0) lhsv + | Clt | Cgt => fSop (OEsltl optR0) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltl optR0) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition cond_int64u (cmp: comparison) (lhsv: list_hsval) (optR0: option bool) := + match cmp with + | Ceq => fSop (OEsequl optR0) lhsv + | Cne => fSop (OEsneul optR0) lhsv + | Clt | Cgt => fSop (OEsltul optR0) lhsv + | Cle | Cge => + let hvs := (fSop (OEsltul optR0) lhsv) in + let hl := make_lhsv_single hvs in + fSop (OExoriw Int.one) hl + end. + +Definition expanse_condimm_int32s (cmp: comparison) (hv1: hsval) (n: int) := + let is_inv := is_inv_cmp_int cmp in + if Int.eq n Int.zero then + let optR0 := make_optR0 true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int32s cmp hl optR0 + else + match cmp with + | Ceq | Cne => + let optR0 := make_optR0 true is_inv in + let hvs := xorimm32 hv1 n false in + let hl := make_lhsv_cmp false hvs hvs in + cond_int32s cmp hl optR0 + | Clt => sltimm32 hv1 n false + | Cle => + if Int.eq n (Int.repr Int.max_signed) then + loadimm32 hv1 Int.one false + else sltimm32 hv1 (Int.add n Int.one) false + | _ => + let optR0 := make_optR0 false is_inv in + let hvs := loadimm32 hv1 n false in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int32s cmp hl optR0 + end. + +Definition expanse_condimm_int32u (cmp: comparison) (hv1: hsval) (n: int) := + let is_inv := is_inv_cmp_int cmp in + if Int.eq n Int.zero then + let optR0 := make_optR0 true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int32u cmp hl optR0 + else + match cmp with + | Clt => sltuimm32 hv1 n false + | _ => + let optR0 := make_optR0 false is_inv in + let hvs := loadimm32 hv1 n false in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int32u cmp hl optR0 + end. + +Definition expanse_condimm_int64s (cmp: comparison) (hv1: hsval) (n: int64) := + let is_inv := is_inv_cmp_int cmp in + if Int64.eq n Int64.zero then + let optR0 := make_optR0 true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int64s cmp hl optR0 + else + match cmp with + | Ceq | Cne => + let optR0 := make_optR0 true is_inv in + let hvs := xorimm64 hv1 n in + let hl := make_lhsv_cmp false hvs hvs in + cond_int64s cmp hl optR0 + | Clt => sltimm64 hv1 n + | Cle => + if Int64.eq n (Int64.repr Int64.max_signed) then + loadimm32 hv1 Int.one true + else sltimm64 hv1 (Int64.add n Int64.one) + | _ => + let optR0 := make_optR0 false is_inv in + let hvs := loadimm64 hv1 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int64s cmp hl optR0 + end. + +Definition expanse_condimm_int64u (cmp: comparison) (hv1: hsval) (n: int64) := + let is_inv := is_inv_cmp_int cmp in + if Int64.eq n Int64.zero then + let optR0 := make_optR0 true is_inv in + let hl := make_lhsv_cmp is_inv hv1 hv1 in + cond_int64u cmp hl optR0 + else + match cmp with + | Clt => sltuimm64 hv1 n + | _ => + let optR0 := make_optR0 false is_inv in + let hvs := loadimm64 hv1 n in + let hl := make_lhsv_cmp is_inv hv1 hvs in + cond_int64u cmp hl optR0 + end. + +Definition cond_float (cmp: comparison) (lhsv: list_hsval) := + match cmp with + | Ceq | Cne => fSop OEfeqd lhsv + | Clt | Cgt => fSop OEfltd lhsv + | Cle | Cge => fSop OEfled lhsv + end. + +Definition cond_single (cmp: comparison) (lhsv: list_hsval) := + match cmp with + | Ceq | Cne => fSop OEfeqs lhsv + | Clt | Cgt => fSop OEflts lhsv + | Cle | Cge => fSop OEfles lhsv + end. + +Definition is_normal_cmp cmp := + match cmp with | Cne => false | _ => true end. + +Definition expanse_cond_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) := + let normal := is_normal_cmp cmp in + let normal' := if cnot then negb normal else normal in + let hvs := fn_cond cmp lhsv in + let hl := make_lhsv_single hvs in + if normal' then hvs else fSop (OExoriw Int.one) hl. + +(* Branches instructions *) + +Definition transl_cbranch_int32s (cmp: comparison) (optR0: option bool) := + match cmp with + | Ceq => CEbeqw optR0 + | Cne => CEbnew optR0 + | Clt => CEbltw optR0 + | Cle => CEbgew optR0 + | Cgt => CEbltw optR0 + | Cge => CEbgew optR0 + end. + +Definition transl_cbranch_int32u (cmp: comparison) (optR0: option bool) := + match cmp with + | Ceq => CEbequw optR0 + | Cne => CEbneuw optR0 + | Clt => CEbltuw optR0 + | Cle => CEbgeuw optR0 + | Cgt => CEbltuw optR0 + | Cge => CEbgeuw optR0 + end. + +Definition transl_cbranch_int64s (cmp: comparison) (optR0: option bool) := + match cmp with + | Ceq => CEbeql optR0 + | Cne => CEbnel optR0 + | Clt => CEbltl optR0 + | Cle => CEbgel optR0 + | Cgt => CEbltl optR0 + | Cge => CEbgel optR0 + end. + +Definition transl_cbranch_int64u (cmp: comparison) (optR0: option bool) := + match cmp with + | Ceq => CEbequl optR0 + | Cne => CEbneul optR0 + | Clt => CEbltul optR0 + | Cle => CEbgeul optR0 + | Cgt => CEbltul optR0 + | Cge => CEbgeul optR0 + end. + +Definition expanse_cbranch_fp (cnot: bool) fn_cond cmp (lhsv: list_hsval) : (condition * list_hsval) := + let normal := is_normal_cmp cmp in + let normal' := if cnot then negb normal else normal in + let hvs := fn_cond cmp lhsv in + let hl := make_lhsv_cmp false hvs hvs in + if normal' then ((CEbnew (Some false)), hl) else ((CEbeqw (Some false)), hl). + +(** Target op simplifications using "fake" values *) + +Definition target_op_simplify (op: operation) (lr: list reg) (hst: hsistate_local): option hsval := + match op, lr with + | Ocmp (Ccomp c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR0 := make_optR0 false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int32s c lhsv optR0) + | Ocmp (Ccompu c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR0 := make_optR0 false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int32u c lhsv optR0) + | Ocmp (Ccompimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int32s c hv1 imm) + | Ocmp (Ccompuimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int32u c hv1 imm) + | Ocmp (Ccompl c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR0 := make_optR0 false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int64s c lhsv optR0) + | Ocmp (Ccomplu c), a1 :: a2 :: nil => + let hv1 := fsi_sreg_get hst a1 in + let hv2 := fsi_sreg_get hst a2 in + let is_inv := is_inv_cmp_int c in + let optR0 := make_optR0 false is_inv in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond_int64u c lhsv optR0) + | Ocmp (Ccomplimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int64s c hv1 imm) + | Ocmp (Ccompluimm c imm), a1 :: nil => + let hv1 := fsi_sreg_get hst a1 in + Some (expanse_condimm_int64u c hv1 imm) + | Ocmp (Ccompf c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp false cond_float c lhsv) + | Ocmp (Cnotcompf c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp true cond_float c lhsv) + | Ocmp (Ccompfs c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp false cond_single c lhsv) + | Ocmp (Cnotcompfs c), f1 :: f2 :: nil => + let hv1 := fsi_sreg_get hst f1 in + let hv2 := fsi_sreg_get hst f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cond_fp true cond_single c lhsv) + | _, _ => None + end. + +Definition target_cbranch_expanse (prev: hsistate_local) (cond: condition) (args: list reg) : option (condition * list_hsval) := + match cond, args with + | (Ccomp c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccompu c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccompimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int.eq n Int.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int32s c (make_optR0 true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm32 hv1 n false in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int32s c (make_optR0 false is_inv) in + Some (cond, lhsv)) + | (Ccompuimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int.eq n Int.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int32u c (make_optR0 true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm32 hv1 n false in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int32u c (make_optR0 false is_inv) in + Some (cond, lhsv)) + | (Ccompl c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccomplu c), (a1 :: a2 :: nil) => + let is_inv := is_inv_cmp_int c in + let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + let hv1 := fsi_sreg_get prev a1 in + let hv2 := fsi_sreg_get prev a2 in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (cond, lhsv) + | (Ccomplimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int64.eq n Int64.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int64s c (make_optR0 true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm64 hv1 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int64s c (make_optR0 false is_inv) in + Some (cond, lhsv)) + | (Ccompluimm c n), (a1 :: nil) => + let is_inv := is_inv_cmp_int c in + let hv1 := fsi_sreg_get prev a1 in + (if Int64.eq n Int64.zero then + let lhsv := make_lhsv_cmp is_inv hv1 hv1 in + let cond := transl_cbranch_int64u c (make_optR0 true is_inv) in + Some (cond, lhsv) + else + let hvs := loadimm64 hv1 n in + let lhsv := make_lhsv_cmp is_inv hv1 hvs in + let cond := transl_cbranch_int64u c (make_optR0 false is_inv) in + Some (cond, lhsv)) + | (Ccompf c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp false cond_float c lhsv) + | (Cnotcompf c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp true cond_float c lhsv) + | (Ccompfs c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp false cond_single c lhsv) + | (Cnotcompfs c), (f1 :: f2 :: nil) => + let hv1 := fsi_sreg_get prev f1 in + let hv2 := fsi_sreg_get prev f2 in + let is_inv := is_inv_cmp_float c in + let lhsv := make_lhsv_cmp is_inv hv1 hv2 in + Some (expanse_cbranch_fp true cond_single c lhsv) + | _, _ => None + end. + +(** Auxiliary lemmas on comparisons *) + +(* Signed ints *) + +Lemma xor_neg_ltle_cmp: forall v1 v2, + Some (Val.xor (Val.cmp Clt v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmp_bool Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + unfold Val.cmp; simpl; + try rewrite Int.eq_sym; + try destruct (Int.eq _ _); try destruct (Int.lt _ _) eqn:ELT ; simpl; + try rewrite Int.xor_one_one; try rewrite Int.xor_zero_one; + auto. +Qed. + +(* Unsigned ints *) + +Lemma xor_neg_ltle_cmpu: forall mptr v1 v2, + Some (Val.xor (Val.cmpu (Mem.valid_pointer mptr) Clt v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer mptr) Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + unfold Val.cmpu; simpl; + try rewrite Int.eq_sym; + try destruct (Int.eq _ _); try destruct (Int.ltu _ _) eqn:ELT ; simpl; + try rewrite Int.xor_one_one; try rewrite Int.xor_zero_one; + auto. + 1,2: + unfold Val.cmpu, Val.cmpu_bool; + destruct Archi.ptr64; try destruct (_ && _); try destruct (_ || _); + try destruct (eq_block _ _); auto. + unfold Val.cmpu, Val.cmpu_bool; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +Remark ltu_12_wordsize: + Int.ltu (Int.repr 12) Int.iwordsize = true. +Proof. + unfold Int.iwordsize, Int.zwordsize. simpl. + unfold Int.ltu. apply zlt_true. + rewrite !Int.unsigned_repr; try cbn; try omega. +Qed. + +(* Signed longs *) + +Lemma xor_neg_ltle_cmpl: forall v1 v2, + Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpl_bool Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.lt _ _); auto. +Qed. + +Lemma xor_neg_ltge_cmpl: forall v1 v2, + Some (Val.xor (Val.maketotal (Val.cmpl Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpl_bool Cge v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.lt _ _); auto. +Qed. + +Lemma xorl_zero_eq_cmpl: forall c v1 v2, + c = Ceq \/ c = Cne -> + Some + (Val.maketotal + (option_map Val.of_bool + (Val.cmpl_bool c (Val.xorl v1 v2) (Vlong Int64.zero)))) = + Some (Val.of_optbool (Val.cmpl_bool c v1 v2)). +Proof. + intros. destruct c; inv H; try discriminate; + destruct v1, v2; simpl; auto; + destruct (Int64.eq i i0) eqn:EQ0. + 1,3: + apply Int64.same_if_eq in EQ0; subst; + rewrite Int64.xor_idem; + rewrite Int64.eq_true; trivial. + 1,2: + destruct (Int64.eq (Int64.xor i i0) Int64.zero) eqn:EQ1; simpl; try congruence; + rewrite Int64.xor_is_zero in EQ1; congruence. +Qed. + +Lemma cmp_ltle_add_one: forall v n, + Int.eq n (Int.repr Int.max_signed) = false -> + Some (Val.of_optbool (Val.cmp_bool Clt v (Vint (Int.add n Int.one)))) = + Some (Val.of_optbool (Val.cmp_bool Cle v (Vint n))). +Proof. + intros v n EQMAX. unfold Val.cmp_bool; destruct v; simpl; auto. + unfold Int.lt. replace (Int.signed (Int.add n Int.one)) with (Int.signed n + 1). + destruct (zlt (Int.signed n) (Int.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int.add_signed. symmetry; apply Int.signed_repr. + specialize (Int.eq_spec n (Int.repr Int.max_signed)). + rewrite EQMAX; simpl; intros. + assert (Int.signed n <> Int.max_signed). + { red; intros E. elim H. rewrite <- (Int.repr_signed n). rewrite E. auto. } + generalize (Int.signed_range n); omega. +Qed. + +Lemma cmpl_ltle_add_one: forall v n, + Int64.eq n (Int64.repr Int64.max_signed) = false -> + Some (Val.of_optbool (Val.cmpl_bool Clt v (Vlong (Int64.add n Int64.one)))) = + Some (Val.of_optbool (Val.cmpl_bool Cle v (Vlong n))). +Proof. + intros v n EQMAX. unfold Val.cmpl_bool; destruct v; simpl; auto. + unfold Int64.lt. replace (Int64.signed (Int64.add n Int64.one)) with (Int64.signed n + 1). + destruct (zlt (Int64.signed n) (Int64.signed i)). + rewrite zlt_false by omega. auto. + rewrite zlt_true by omega. auto. + rewrite Int64.add_signed. symmetry; apply Int64.signed_repr. + specialize (Int64.eq_spec n (Int64.repr Int64.max_signed)). + rewrite EQMAX; simpl; intros. + assert (Int64.signed n <> Int64.max_signed). + { red; intros E. elim H. rewrite <- (Int64.repr_signed n). rewrite E. auto. } + generalize (Int64.signed_range n); omega. +Qed. + +Remark lt_maxsgn_false_int: forall i, + Int.lt (Int.repr Int.max_signed) i = false. +Proof. + intros; unfold Int.lt. + specialize Int.signed_range with i; intros. + rewrite zlt_false; auto. destruct H. + rewrite Int.signed_repr; try (cbn; lia). + apply Z.le_ge. trivial. +Qed. + +Remark lt_maxsgn_false_long: forall i, + Int64.lt (Int64.repr Int64.max_signed) i = false. +Proof. + intros; unfold Int64.lt. + specialize Int64.signed_range with i; intros. + rewrite zlt_false; auto. destruct H. + rewrite Int64.signed_repr; try (cbn; lia). + apply Z.le_ge. trivial. +Qed. + +(* Unsigned longs *) + +Lemma xor_neg_ltle_cmplu: forall mptr v1 v2, + Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer mptr) Cle v2 v1)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.ltu _ _); auto. + 1,2: unfold Val.cmplu; simpl; auto; + destruct (Archi.ptr64); simpl; + try destruct (eq_block _ _); simpl; + try destruct (_ && _); simpl; + try destruct (Ptrofs.cmpu _ _); + try destruct cmp; simpl; auto. + unfold Val.cmplu; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +Lemma xor_neg_ltge_cmplu: forall mptr v1 v2, + Some (Val.xor (Val.maketotal (Val.cmplu (Mem.valid_pointer mptr) Clt v1 v2)) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer mptr) Cge v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence. + destruct (Int64.ltu _ _); auto. + 1,2: unfold Val.cmplu; simpl; auto; + destruct (Archi.ptr64); simpl; + try destruct (eq_block _ _); simpl; + try destruct (_ && _); simpl; + try destruct (Ptrofs.cmpu _ _); + try destruct cmp; simpl; auto. + unfold Val.cmplu; simpl; + destruct Archi.ptr64; try destruct (_ || _); simpl; auto; + destruct (eq_block b b0); destruct (eq_block b0 b); + try congruence; + try destruct (_ || _); simpl; try destruct (Ptrofs.ltu _ _); + simpl; auto; + repeat destruct (_ && _); simpl; auto. +Qed. + +(* Floats *) + +Lemma xor_neg_eqne_cmpf: forall v1 v2, + Some (Val.xor (Val.cmpf Ceq v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpf_bool Cne v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence; + unfold Val.cmpf; simpl. + rewrite Float.cmp_ne_eq. + destruct (Float.cmp _ _ _); simpl; auto. +Qed. + +(* Singles *) + +Lemma xor_neg_eqne_cmpfs: forall v1 v2, + Some (Val.xor (Val.cmpfs Ceq v1 v2) (Vint Int.one)) = + Some (Val.of_optbool (Val.cmpfs_bool Cne v1 v2)). +Proof. + intros. eapply f_equal. + destruct v1, v2; simpl; try congruence; + unfold Val.cmpfs; simpl. + rewrite Float32.cmp_ne_eq. + destruct (Float32.cmp _ _ _); simpl; auto. +Qed. + +(* More useful lemmas *) + +Lemma xor_neg_optb: forall v, + Some (Val.xor (Val.of_optbool (option_map negb v)) + (Vint Int.one)) = Some (Val.of_optbool v). +Proof. + intros. + destruct v; simpl; trivial. + destruct b; simpl; auto. +Qed. + +Lemma xor_neg_optb': forall v, + Some (Val.xor (Val.of_optbool v) (Vint Int.one)) = + Some (Val.of_optbool (option_map negb v)). +Proof. + intros. + destruct v; simpl; trivial. + destruct b; simpl; auto. +Qed. + +Lemma optbool_mktotal: forall v, + Val.maketotal (option_map Val.of_bool v) = + Val.of_optbool v. +Proof. + intros. + destruct v; simpl; auto. +Qed. + +(* TODO gourdinl move to common/Values ? *) +Theorem swap_cmpf_bool: + forall c x y, + Val.cmpf_bool (swap_comparison c) x y = Val.cmpf_bool c y x. +Proof. + destruct x; destruct y; simpl; auto. rewrite Float.cmp_swap. auto. +Qed. + +Theorem swap_cmpfs_bool: + forall c x y, + Val.cmpfs_bool (swap_comparison c) x y = Val.cmpfs_bool c y x. +Proof. + destruct x; destruct y; simpl; auto. rewrite Float32.cmp_swap. auto. +Qed. + +(* Intermediates lemmas on each expansed instruction *) + +Lemma simplify_ccomp_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (cond_int32s c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmp_bool c v v0)). +Proof. + intros. + unfold cond_int32s in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmp. + - apply xor_neg_ltle_cmp. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmp_bool; trivial. + - replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmp_bool. + rewrite xor_neg_optb; trivial. +Qed. + +Lemma simplify_ccompu_correct ge sp hst st c r r0 rs0 m m0 v v0: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj + (cond_int32u c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer m) c v v0)). +Proof. + intros. + erewrite (cmpu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)). + 2: eauto. + unfold cond_int32u in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpu. + - apply xor_neg_ltle_cmpu. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmpu_bool; trivial. + - replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmpu_bool. + rewrite xor_neg_optb; trivial. +Qed. + +Lemma simplify_ccompimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int32s c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmp_bool c v (Vint n))). +Proof. + intros. + unfold expanse_condimm_int32s, cond_int32s in *; destruct c; + intros; destruct (Int.eq n Int.zero) eqn:EQIMM; simpl; + try apply Int.same_if_eq in EQIMM; subst; + unfold loadimm32, sltimm32, xorimm32, opimm32, load_hilo32; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmp, zero32. + all: + try apply xor_neg_ltle_cmp; + try apply xor_neg_ltge_cmp; trivial. + 4: + try destruct (Int.eq n (Int.repr Int.max_signed)) eqn:EQMAX; subst; + try apply Int.same_if_eq in EQMAX; subst; simpl. + 4: + intros; try (specialize make_immed32_sound with (Int.one); + destruct (make_immed32 Int.one) eqn:EQMKI_A1); intros; simpl. + 6: + intros; try (specialize make_immed32_sound with (Int.add n Int.one); + destruct (make_immed32 (Int.add n Int.one)) eqn:EQMKI_A2); intros; simpl. + 1,2,3,8,9: + intros; try (specialize make_immed32_sound with (n); + destruct (make_immed32 n) eqn:EQMKI); intros; simpl. + all: + try destruct (Int.eq lo Int.zero) eqn:EQLO32; + try apply Int.same_if_eq in EQLO32; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + try rewrite (Int.add_commut _ Int.zero), Int.add_zero_l in H; subst; + try rewrite xor_neg_ltle_cmp; trivial; + unfold Val.cmp, may_undef_int, zero32, Val.add; simpl; + destruct v; auto. + all: + try rewrite ltu_12_wordsize; + try rewrite <- H; + try (apply cmp_ltle_add_one; auto); + try rewrite Int.add_commut, Int.add_zero_l in *; + try ( + simpl; trivial; + try rewrite Int.xor_is_zero; + try destruct (Int.lt _ _) eqn:EQLT; trivial; + try rewrite lt_maxsgn_false_int in EQLT; + simpl; trivial; try discriminate; fail). +Qed. + +Lemma simplify_ccompuimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int32u c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmpu_bool (Mem.valid_pointer m) c v (Vint n))). +Proof. + intros. + assert (HMEM: Val.cmpu_bool (Mem.valid_pointer m) c v (Vint n) = + Val.cmpu_bool (Mem.valid_pointer m0) c v (Vint n)). + erewrite (cmpu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)); eauto. + unfold expanse_condimm_int32u, cond_int32u in *; destruct c; + intros; destruct (Int.eq n Int.zero) eqn:EQIMM; simpl; + try apply Int.same_if_eq in EQIMM; subst; + unfold loadimm32, sltuimm32, opimm32, load_hilo32; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; trivial; + try rewrite xor_neg_ltle_cmpu; + unfold Val.cmpu, zero32. + all: + try (specialize make_immed32_sound with n; + destruct (make_immed32 n) eqn:EQMKI); + try destruct (Int.eq lo Int.zero) eqn:EQLO; + try apply Int.same_if_eq in EQLO; subst; + intros; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + rewrite HMEM; + unfold may_undef_int, Val.cmpu; + destruct v; simpl; auto; + try rewrite EQIMM; try destruct (Archi.ptr64); simpl; + try rewrite ltu_12_wordsize; trivial; + try rewrite Int.add_commut, Int.add_zero_l; + try destruct (Int.ltu _ _) eqn:EQLTU; simpl; + try rewrite EQLTU; simpl; + trivial. +Qed. + +Lemma simplify_ccompl_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (cond_int64s c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmpl_bool c v v0)). +Proof. + intros. + unfold cond_int64s in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpl. + 1,2,3: rewrite optbool_mktotal; trivial. + - apply xor_neg_ltle_cmpl. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmpl_bool; trivial. + rewrite optbool_mktotal; trivial. + - apply xor_neg_ltge_cmpl. +Qed. + +Lemma simplify_ccomplu_correct ge sp hst st c r r0 rs0 m m0 v v0: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj + (cond_int64u c + (make_lhsv_cmp (is_inv_cmp_int c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)) None)) rs0 m0 = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer m) c v v0)). +Proof. + intros. + erewrite (cmplu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)). + 2: eauto. + unfold cond_int64u in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmplu. + 1,2,3: rewrite optbool_mktotal; trivial. + - apply xor_neg_ltle_cmplu. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmplu_bool; trivial. + rewrite optbool_mktotal; trivial. + - apply xor_neg_ltge_cmplu. +Qed. + +Lemma simplify_ccomplimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int64s c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmpl_bool c v (Vlong n))). +Proof. + intros. + unfold expanse_condimm_int64s, cond_int64s in *; destruct c; + intros; destruct (Int64.eq n Int64.zero) eqn:EQIMM; simpl; + try apply Int64.same_if_eq in EQIMM; subst; + unfold loadimm32, loadimm64, sltimm64, xorimm64, opimm64, load_hilo32, load_hilo64; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmpl, zero64. + all: + try apply xor_neg_ltle_cmpl; + try apply xor_neg_ltge_cmpl; + try rewrite optbool_mktotal; trivial. + 4: + try destruct (Int64.eq n (Int64.repr Int64.max_signed)) eqn:EQMAX; subst; + try apply Int64.same_if_eq in EQMAX; subst; simpl. + 4: + intros; try (specialize make_immed32_sound with (Int.one); + destruct (make_immed32 Int.one) eqn:EQMKI_A1); intros; simpl. + 6: + intros; try (specialize make_immed64_sound with (Int64.add n Int64.one); + destruct (make_immed64 (Int64.add n Int64.one)) eqn:EQMKI_A2); intros; simpl. + 1,2,3,9,10: + intros; try (specialize make_immed64_sound with (n); + destruct (make_immed64 n) eqn:EQMKI); intros; simpl. + all: + try destruct (Int.eq lo Int.zero) eqn:EQLO32; + try apply Int.same_if_eq in EQLO32; subst; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO64; + try apply Int64.same_if_eq in EQLO64; subst; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + unfold may_undef_luil; + try rewrite (Int64.add_commut _ Int64.zero), Int64.add_zero_l in H; subst; + try fold (Val.cmpl Clt v (Vlong imm)); + try rewrite xor_neg_ltge_cmpl; trivial; + try rewrite xor_neg_ltle_cmpl; trivial; + unfold Val.cmpl, may_undef_luil, Val.addl; + try rewrite xorl_zero_eq_cmpl; trivial; + try rewrite optbool_mktotal; trivial; + unfold may_undef_int, zero32, Val.add; simpl; + destruct v; auto. + 6,7,8: + try rewrite <- optbool_mktotal; trivial; + try rewrite Int64.add_commut, Int64.add_zero_l in *; + try fold (Val.cmpl Clt (Vlong i) (Vlong imm)); + try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))))); + try fold (Val.cmpl Clt (Vlong i) (Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo))); + try rewrite xor_neg_ltge_cmpl; trivial; + try rewrite xor_neg_ltle_cmpl; trivial. + all: + try rewrite <- H; + try apply cmpl_ltle_add_one; auto; + try rewrite ltu_12_wordsize; + try rewrite Int.add_commut, Int.add_zero_l in *; + try rewrite Int64.add_commut, Int64.add_zero_l in *; + simpl; try rewrite lt_maxsgn_false_long; + try (rewrite <- H; trivial; fail); + simpl; trivial. +Qed. + +Lemma simplify_ccompluimm_correct ge sp hst st c r n rs0 m m0 v: forall + (SMEM : forall (m : mem) (b : Values.block) (ofs : Z), + seval_smem ge sp (si_smem st) rs0 m0 = Some m -> + Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OK2 : seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp + (hsval_proj (expanse_condimm_int64u c (fsi_sreg_get hst r) n)) rs0 m0 = + Some (Val.of_optbool (Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong n))). +Proof. + intros. + assert (HMEM: Val.cmplu_bool (Mem.valid_pointer m) c v (Vlong n) = + Val.cmplu_bool (Mem.valid_pointer m0) c v (Vlong n)). + erewrite (cmplu_bool_valid_pointer_eq (Mem.valid_pointer m) (Mem.valid_pointer m0)); eauto. + unfold expanse_condimm_int64u, cond_int64u in *; destruct c; + intros; destruct (Int64.eq n Int64.zero) eqn:EQIMM; simpl; + unfold loadimm64, sltuimm64, opimm64, load_hilo64; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + unfold Val.cmplu, zero64. + (* Simplify make immediate and decompose subcases *) + all: + try (specialize make_immed64_sound with n; + destruct (make_immed64 n) eqn:EQMKI); + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + try erewrite fSop_correct; eauto; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; + try rewrite OK2; + rewrite HMEM. + (* Ceq, Cne, Clt = itself *) + all: intros; try apply Int64.same_if_eq in EQIMM; subst; trivial. + (* Cle = xor (Clt) *) + all: try apply xor_neg_ltle_cmplu; trivial. + (* Others subcases with swap/negation *) + all: + unfold Val.cmplu, may_undef_int, zero64, Val.addl; + try apply Int64.same_if_eq in EQLO; subst; + try rewrite Int64.add_commut, Int64.add_zero_l in *; trivial; + try (rewrite <- xor_neg_ltle_cmplu; unfold Val.cmplu; + trivial; fail); + try (replace (Clt) with (swap_comparison Cgt) by auto; + rewrite Val.swap_cmplu_bool; trivial; fail); + try (replace (Clt) with (negate_comparison Cge) by auto; + rewrite Val.negate_cmplu_bool; rewrite xor_neg_optb; trivial; fail); + try rewrite optbool_mktotal; trivial. + all: + try destruct v; simpl; auto; + try destruct (Archi.ptr64); simpl; + try rewrite EQIMM; + try rewrite HMEM; trivial; + try destruct (Int64.ltu _ _); + try rewrite <- xor_neg_ltge_cmplu; unfold Val.cmplu; + try rewrite <- optbool_mktotal; trivial. +Qed. + +Lemma simplify_ccompf_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp false cond_float c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (Val.cmpf_bool c v v0)). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpf. + - apply xor_neg_eqne_cmpf. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite swap_cmpf_bool; trivial. + - replace (Cle) with (swap_comparison Cge) by auto; + rewrite swap_cmpf_bool; trivial. +Qed. + +Lemma simplify_cnotcompf_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp true cond_float c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (option_map negb (Val.cmpf_bool c v v0))). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpf. + 1,3,4: apply xor_neg_optb'. + all: destruct v, v0; simpl; trivial. + rewrite Float.cmp_ne_eq; rewrite negb_involutive; trivial. + 1: replace (Clt) with (swap_comparison Cgt) by auto; rewrite <- Float.cmp_swap; simpl. + 2: replace (Cle) with (swap_comparison Cge) by auto; rewrite <- Float.cmp_swap; simpl. + all: destruct (Float.cmp _ _ _); trivial. +Qed. + +Lemma simplify_ccompfs_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp false cond_single c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (Val.cmpfs_bool c v v0)). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpfs. + - apply xor_neg_eqne_cmpfs. + - replace (Clt) with (swap_comparison Cgt) by auto; + rewrite swap_cmpfs_bool; trivial. + - replace (Cle) with (swap_comparison Cge) by auto; + rewrite swap_cmpfs_bool; trivial. +Qed. + +Lemma simplify_cnotcompfs_correct ge sp hst st c r r0 rs0 m0 v v0: forall + (SREG: forall r: positive, + hsi_sreg_eval ge sp hst r rs0 m0 = + seval_sval ge sp (si_sreg st r) rs0 m0) + (OKv1 : seval_sval ge sp (si_sreg st r) rs0 m0 = Some v) + (OKv2 : seval_sval ge sp (si_sreg st r0) rs0 m0 = Some v0), + seval_sval ge sp + (hsval_proj + (expanse_cond_fp true cond_single c + (make_lhsv_cmp (is_inv_cmp_float c) (fsi_sreg_get hst r) + (fsi_sreg_get hst r0)))) rs0 m0 = + Some (Val.of_optbool (option_map negb (Val.cmpfs_bool c v v0))). +Proof. + intros. + unfold expanse_cond_fp in *; destruct c; simpl; + erewrite !fsi_sreg_get_correct; eauto; + rewrite OKv1, OKv2; trivial; + unfold Val.cmpfs. + 1,3,4: apply xor_neg_optb'. + all: destruct v, v0; simpl; trivial. + rewrite Float32.cmp_ne_eq; rewrite negb_involutive; trivial. + 1: replace (Clt) with (swap_comparison Cgt) by auto; rewrite <- Float32.cmp_swap; simpl. + 2: replace (Cle) with (swap_comparison Cge) by auto; rewrite <- Float32.cmp_swap; simpl. + all: destruct (Float32.cmp _ _ _); trivial. +Qed. + +(* Main proof of simplification *) + +Lemma target_op_simplify_correct op lr hst fsv ge sp rs0 m0 st args m: forall + (H: target_op_simplify op lr hst = Some fsv) + (REF: hsilocal_refines ge sp rs0 m0 hst st) + (OK0: hsok_local ge sp rs0 m0 hst) + (OK1: seval_list_sval ge sp (list_sval_inj (map (si_sreg st) lr)) rs0 m0 = Some args) + (OK2: seval_smem ge sp (si_smem st) rs0 m0 = Some m), + seval_sval ge sp (hsval_proj fsv) rs0 m0 = eval_operation ge sp op args m. +Proof. + unfold target_op_simplify; simpl. + intros H (LREF & SREF & SREG & SMEM) ? ? ?. + destruct op; try congruence. + destruct cond; repeat (destruct lr; simpl; try congruence); + simpl in OK1; + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + inv H; inv OK1. + (* Ccomp *) + - eapply simplify_ccomp_correct; eauto. + (* Ccompu *) + - eapply simplify_ccompu_correct; eauto. + (* Ccompimm *) + - eapply simplify_ccompimm_correct; eauto. + (* Ccompuimm *) + - eapply simplify_ccompuimm_correct; eauto. + (* Ccompl *) + - eapply simplify_ccompl_correct; eauto. + (* Ccomplu *) + - eapply simplify_ccomplu_correct; eauto. + (* Ccomplimm *) + - eapply simplify_ccomplimm_correct; eauto. + (* Ccompluimm *) + - eapply simplify_ccompluimm_correct; eauto. + (* Ccompf *) + - eapply simplify_ccompf_correct; eauto. + (* Cnotcompf *) + - eapply simplify_cnotcompf_correct; eauto. + (* Ccompfs *) + - eapply simplify_ccompfs_correct; eauto. + (* Cnotcompfs *) + - eapply simplify_cnotcompfs_correct; eauto. +Qed. + +Lemma target_cbranch_expanse_correct hst c l ge sp rs0 m0 st c' l': forall + (TARGET: target_cbranch_expanse hst c l = Some (c', l')) + (LREF : hsilocal_refines ge sp rs0 m0 hst st) + (OK: hsok_local ge sp rs0 m0 hst), + seval_condition ge sp c' (hsval_list_proj l') (si_smem st) rs0 m0 = + seval_condition ge sp c (list_sval_inj (map (si_sreg st) l)) (si_smem st) rs0 m0. +Proof. + unfold target_cbranch_expanse, seval_condition; simpl. + intros H (LREF & SREF & SREG & SMEM) ?. + destruct c; try congruence; + repeat (destruct l; simpl in H; try congruence). + 1,2,5,6: + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + try replace (Cle) with (swap_comparison Cge) by auto; + try replace (Clt) with (swap_comparison Cgt) by auto; + try rewrite Val.swap_cmp_bool; trivial; + try rewrite Val.swap_cmpu_bool; trivial; + try rewrite Val.swap_cmpl_bool; trivial; + try rewrite Val.swap_cmplu_bool; trivial. + 1,2,3,4: + try destruct (Int.eq n Int.zero) eqn: EQIMM; + try apply Int.same_if_eq in EQIMM; + try destruct (Int64.eq n Int64.zero) eqn: EQIMM; + try apply Int64.same_if_eq in EQIMM; + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + unfold loadimm32, load_hilo32, Val.cmp, Val.cmpu, zero32; + unfold loadimm64, load_hilo64, Val.cmpl, Val.cmplu, zero64; + intros; try (specialize make_immed32_sound with (n); + destruct (make_immed32 n) eqn:EQMKI); intros; simpl; + intros; try (specialize make_immed64_sound with (n); + destruct (make_immed64 n) eqn:EQMKI); intros; simpl; + try rewrite EQLO; simpl; + try destruct (Int.eq lo Int.zero) eqn:EQLO; + try destruct (Int64.eq lo Int64.zero) eqn:EQLO; + try apply Int.same_if_eq in EQLO; simpl; trivial; + try apply Int64.same_if_eq in EQLO; simpl; trivial; + unfold may_undef_int, may_undef_luil; + try erewrite !fsi_sreg_get_correct; eauto; + try rewrite OKv1; simpl; trivial; + try destruct v; try rewrite H; + try rewrite ltu_12_wordsize; try rewrite EQLO; + try rewrite Int.add_commut, Int.add_zero_l; + try rewrite Int64.add_commut, Int64.add_zero_l; + auto; simpl; + try rewrite H in EQIMM; + try rewrite EQLO in EQIMM; + try rewrite Int.add_commut, Int.add_zero_l in EQIMM; + try rewrite Int64.add_commut, Int64.add_zero_l in EQIMM; + try rewrite EQIMM; simpl; + try destruct (Archi.ptr64); trivial. + + 1,2,3,4: + destruct c; inv H; simpl; + try erewrite !fsi_sreg_get_correct; eauto; + try (destruct (seval_smem ge sp (si_smem st) rs0 m0) eqn:OKmem; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r) rs0 m0) eqn:OKv1; try congruence); + try (destruct (seval_sval ge sp (si_sreg st r0) rs0 m0) eqn:OKv2; try congruence); + unfold zero32, zero64, Val.cmpf, Val.cmpfs; + destruct v, v0; simpl; trivial; + try rewrite Float.cmp_ne_eq; + try rewrite Float32.cmp_ne_eq; + try rewrite <- Float.cmp_swap; simpl; + try rewrite <- Float32.cmp_swap; simpl; + try destruct (Float.cmp _ _); simpl; + try destruct (Float32.cmp _ _); simpl; + try rewrite Int.eq_true; simpl; + try rewrite Int.eq_false; try apply Int.one_not_zero; + simpl; trivial. +Qed. +Global Opaque target_op_simplify. +Global Opaque target_cbranch_expanse. diff --git a/riscV/ValueAOp.v b/riscV/ValueAOp.v index e779b114..97f3ff61 100644 --- a/riscV/ValueAOp.v +++ b/riscV/ValueAOp.v @@ -17,6 +17,34 @@ Require Import Zbits. (** Value analysis for RISC V operators *) +Definition zero32 := (I Int.zero). +Definition zero64 := (L Int64.zero). + +Definition apply_bin_r0 {B} (optR0: option bool) (sem: aval -> aval -> B) (v1 v2 vz: aval): B := + match optR0 with + | None => sem v1 v2 + | Some true => sem vz v1 + | Some false => sem v1 vz + end. + +Definition may_undef_int (is_long: bool) (sem: aval -> aval -> aval) (v1 vimm vz: aval): aval := + if negb is_long then + match v1 with + | I _ => sem vimm vz + | _ => Ifptr Ptop + end + else + match v1 with + | L _ => sem vimm vz + | _ => Ifptr Ptop + end. + +Definition may_undef_luil (v1: aval) (n: int64): aval := + match v1 with + | L _ => sign_ext 32 (shll (L n) (L (Int64.repr 12))) + | _ => Ifptr Ptop + end. + Definition eval_static_condition (cond: condition) (vl: list aval): abool := match cond, vl with | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 @@ -31,6 +59,22 @@ Definition eval_static_condition (cond: condition) (vl: list aval): abool := | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) + | CEbeqw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32 + | CEbnew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32 + | CEbequw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32 + | CEbneuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32 + | CEbltw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32 + | CEbltuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32 + | CEbgew optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmp_bool Cge) v1 v2 zero32 + | CEbgeuw optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpu_bool Cge) v1 v2 zero32 + | CEbeql optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64 + | CEbnel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64 + | CEbequl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64 + | CEbneul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64 + | CEbltl optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64 + | CEbltul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64 + | CEbgel optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmpl_bool Cge) v1 v2 zero64 + | CEbgeul optR0, v1 :: v2 :: nil => apply_bin_r0 optR0 (cmplu_bool Cge) v1 v2 zero64 | _, _ => Bnone end. @@ -170,6 +214,35 @@ 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) + | OEseqw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Ceq) v1 v2 zero32) + | OEsnew optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Cne) v1 v2 zero32) + | OEsequw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Ceq) v1 v2 zero32) + | OEsneuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Cne) v1 v2 zero32) + | OEsltw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmp_bool Clt) v1 v2 zero32) + | OEsltuw optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpu_bool Clt) v1 v2 zero32) + | OEsltiw n, v1::nil => of_optbool (cmp_bool Clt v1 (I n)) + | OEsltiuw n, v1::nil => of_optbool (cmpu_bool Clt v1 (I n)) + | OExoriw n, v1::nil => xor v1 (I n) + | OEluiw n is_long, v1::nil => may_undef_int is_long shl v1 (I n) (I (Int.repr 12)) + | OEaddiwr0 n is_long, v1::nil => may_undef_int is_long add v1 (I n) zero32 + | OEseql optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Ceq) v1 v2 zero64) + | OEsnel optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Cne) v1 v2 zero64) + | OEsequl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Ceq) v1 v2 zero64) + | OEsneul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Cne) v1 v2 zero64) + | OEsltl optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmpl_bool Clt) v1 v2 zero64) + | OEsltul optR0, v1::v2::nil => of_optbool (apply_bin_r0 optR0 (cmplu_bool Clt) v1 v2 zero64) + | OEsltil n, v1::nil => of_optbool (cmpl_bool Clt v1 (L n)) + | OEsltiul n, v1::nil => of_optbool (cmplu_bool Clt v1 (L n)) + | OExoril n, v1::nil => xorl v1 (L n) + | OEluil n, v1::nil => may_undef_luil v1 n + | OEaddilr0 n, v1::nil => may_undef_int true addl v1 (L n) zero64 + | OEloadli n, nil => L (n) + | OEfeqd, v1::v2::nil => of_optbool (cmpf_bool Ceq v1 v2) + | OEfltd, v1::v2::nil => of_optbool (cmpf_bool Clt v1 v2) + | OEfled, v1::v2::nil => of_optbool (cmpf_bool Cle v1 v2) + | OEfeqs, v1::v2::nil => of_optbool (cmpfs_bool Ceq v1 v2) + | OEflts, v1::v2::nil => of_optbool (cmpfs_bool Clt v1 v2) + | OEfles, v1::v2::nil => of_optbool (cmpfs_bool Cle v1 v2) | Obits_of_single, v1::nil => bits_of_single v1 | Obits_of_float, v1::nil => bits_of_float v1 | Osingle_of_bits, v1::nil => single_of_bits v1 @@ -266,7 +339,9 @@ Proof. destruct cond; simpl; eauto with va. inv H2. destruct cond; simpl; eauto with va. - destruct cond; auto with va. + 17: destruct cond; simpl; eauto with va. + all: destruct optR0 as [[]|]; unfold apply_bin_r0, Op.apply_bin_r0; + unfold zero32, Op.zero32, zero64, Op.zero64; eauto with va. Qed. Lemma symbol_address_sound: @@ -307,7 +382,71 @@ Proof. destruct addr; InvHyps; eauto with va. rewrite Ptrofs.add_zero_l; eauto with va. Qed. - + +Lemma of_optbool_maketotal_sound: + forall ob ab, cmatch ob ab -> vmatch bc (Val.maketotal (option_map Val.of_bool ob)) (of_optbool ab). +Proof. + intros. + assert (DEFAULT: vmatch bc (Val.maketotal (option_map Val.of_bool ob)) (Uns Pbot 1)). + { + destruct ob; simpl; auto with va. + destruct b; constructor; try omega. + change 1 with (usize Int.one). apply is_uns_usize. + red; intros. apply Int.bits_zero. + } + inv H; auto. simpl. destruct b; constructor. +Qed. + +Lemma eval_cmpu_sound c: forall a1 b1 a0 b0 optR0 m, + c = Ceq \/ c = Cne \/ c = Clt-> + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc (Op.apply_bin_r0 optR0 (Val.cmpu (Mem.valid_pointer m) c) a1 a0 Op.zero32) + (of_optbool (apply_bin_r0 optR0 (cmpu_bool c) b1 b0 zero32)). +Proof. + intros. + destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. +Qed. + +Lemma eval_cmplu_sound c: forall a1 b1 a0 b0 optR0 m, + c = Ceq \/ c = Cne \/ c = Clt-> + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc + (Val.maketotal + (Op.apply_bin_r0 optR0 (Val.cmplu (Mem.valid_pointer m) c) a1 a0 + Op.zero64)) + (of_optbool (apply_bin_r0 optR0 (cmplu_bool c) b1 b0 zero64)). +Proof. + intros. + destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. +Qed. + +Lemma eval_cmp_sound: forall a1 b1 a0 b0 optR0 cmp, + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc (Op.apply_bin_r0 optR0 (Val.cmp cmp) a1 a0 Op.zero32) + (of_optbool (apply_bin_r0 optR0 (cmp_bool cmp) b1 b0 zero32)). +Proof. + intros. + destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + apply of_optbool_sound; unfold Op.zero32, zero32; eauto with va. +Qed. + +Lemma eval_cmpl_sound: forall a1 b1 a0 b0 optR0 cmp, + vmatch bc a1 b1 -> + vmatch bc a0 b0 -> + vmatch bc + (Val.maketotal (Op.apply_bin_r0 optR0 (Val.cmpl cmp) a1 a0 Op.zero64)) + (of_optbool (apply_bin_r0 optR0 (cmpl_bool cmp) b1 b0 zero64)). +Proof. + intros. + destruct optR0 as [[]|]; unfold Op.apply_bin_r0, apply_bin_r0; + apply of_optbool_maketotal_sound; unfold Op.zero64, zero64; eauto with va. +Qed. + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> @@ -320,6 +459,25 @@ Proof. destruct (propagate_float_constants tt); constructor. rewrite Ptrofs.add_zero_l; eauto with va. apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + + 3,4,6: apply eval_cmpu_sound; auto. + 1,2,3: apply eval_cmp_sound; auto. + unfold Val.cmp; apply of_optbool_sound; eauto with va. + unfold Val.cmpu; apply of_optbool_sound; eauto with va. + unfold zero32; simpl; eauto with va. + + 1,2,11,12: + try unfold Op.may_undef_int, may_undef_int, Op.zero32, zero32, Op.zero64, zero64; + try unfold Op.may_undef_luil, may_undef_luil; simpl; unfold ntop1; + inv H1; try destruct is_long; simpl; try destruct (Int.ltu _ _); eauto with va; + try apply vmatch_ifptr_i; try apply vmatch_ifptr_l. + + 3,4,6: apply eval_cmplu_sound; auto. + 1,2,3: apply eval_cmpl_sound; auto. + unfold Val.cmpl; apply of_optbool_maketotal_sound; eauto with va. + unfold Val.cmplu; apply of_optbool_maketotal_sound; eauto with va. + unfold zero64; simpl; eauto with va. + all: unfold Val.cmpf; apply of_optbool_sound; eauto with va. Qed. End SOUNDNESS. diff --git a/scheduling/RTLpath.v b/scheduling/RTLpath.v index cccc8147..5b34dc16 100644 --- a/scheduling/RTLpath.v +++ b/scheduling/RTLpath.v @@ -85,6 +85,7 @@ Record path_info := { psize: nat; (* number minus 1 of instructions in the path *) input_regs: Regset.t; (** Registers that are used (as input_regs) by the "fallthrough successors" of the path *) + pre_output_regs: Regset.t; (** This field is not used by the verificator, but is helpful for the superblock scheduler *) output_regs: Regset.t }. diff --git a/scheduling/RTLpathCommon.ml b/scheduling/RTLpathCommon.ml new file mode 100644 index 00000000..3d123ba8 --- /dev/null +++ b/scheduling/RTLpathCommon.ml @@ -0,0 +1,14 @@ +open Maps +open Registers +open Camlcoq + +type superblock = { + mutable instructions: P.t array; (* pointers to code instructions *) + (* each predicted Pcb has its attached liveins *) + (* This is indexed by the pc value *) + mutable liveins: Regset.t PTree.t; + (* Union of the input_regs of the last successors *) + s_output_regs: Regset.t; + typing: RTLtyping.regenv +} + diff --git a/scheduling/RTLpathLivegen.v b/scheduling/RTLpathLivegen.v index 1f0ebe3c..9f646ad0 100644 --- a/scheduling/RTLpathLivegen.v +++ b/scheduling/RTLpathLivegen.v @@ -46,7 +46,6 @@ Proof. inversion_ASSERT; try_simplify_someHyps. Qed. -(* FIXME - what about trap? *) Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option (Regset.t * node) := match i with | Inop pc' => Some (alive, pc') @@ -63,7 +62,7 @@ Definition iinst_checker (pm: path_map) (alive: Regset.t) (i: instruction): opti | Icond cond args ifso ifnot _ => ASSERT list_mem args alive IN exit_checker pm alive ifso (alive, ifnot) - | _ => None (* TODO jumptable ? *) + | _ => None end. @@ -109,6 +108,20 @@ Proof. * intros; eapply iinst_checker_path_entry; eauto. Qed. + +Lemma ipath_checker_default_succ (f: RTLpath.function) path: forall alive pc res, + ipath_checker path f (fn_path f) alive pc = Some res + -> nth_default_succ (fn_code f) path pc = Some (snd res). +Proof. + induction path; simpl. + + try_simplify_someHyps. + + intros alive pc res. + inversion_SOME i; intros INST. + inversion_SOME res0; intros ICHK IPCHK. + rewrite INST. + erewrite iinst_checker_default_succ; eauto. +Qed. + Definition reg_option_mem (or: option reg) (alive: Regset.t) := match or with None => true | Some r => Regset.mem r alive end. @@ -152,47 +165,69 @@ Qed. Local Hint Resolve exit_list_checker_correct: core. -Definition inst_checker (pm: path_map) (alive: Regset.t) (i: instruction): option unit := +Definition final_inst_checker (pm: path_map) (alive por: Regset.t) (i: instruction): option unit := match i with | Icall sig ros args res pc' => ASSERT list_mem args alive IN ASSERT reg_sum_mem ros alive IN - exit_checker pm (Regset.add res alive) pc' tt + exit_checker pm (Regset.add res por) pc' tt | Itailcall sig ros args => ASSERT list_mem args alive IN ASSERT reg_sum_mem ros alive IN Some tt | Ibuiltin ef args res pc' => - ASSERT list_mem (params_of_builtin_args args) alive IN - exit_checker pm (reg_builtin_res res alive) pc' tt + ASSERT list_mem (params_of_builtin_args args) alive IN + exit_checker pm (reg_builtin_res res por) pc' tt | Ijumptable arg tbl => ASSERT Regset.mem arg alive IN - ASSERT exit_list_checker pm alive tbl IN + ASSERT exit_list_checker pm por tbl IN Some tt | Ireturn optarg => - ASSERT (reg_option_mem optarg) alive IN + ASSERT (reg_option_mem optarg) alive IN Some tt - | _ => - SOME res <- iinst_checker pm alive i IN - exit_checker pm (fst res) (snd res) tt + | _ => None end. -Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive: Regset.t) (i: instruction): - inst_checker pm alive i = Some tt -> +Lemma final_inst_checker_wellformed (c:code) pc (pm: path_map) (alive por: Regset.t) (i: instruction): + final_inst_checker pm alive por i = Some tt -> c!pc = Some i -> wellformed_path c pm 0 pc. Proof. intros CHECK PC. eapply wf_last_node; eauto. clear c pc PC. intros pc PC. destruct i; simpl in * |- *; intuition (subst; eauto); try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). - intros X; exploit exit_checker_res; eauto. - clear X. intros; subst; eauto. +Qed. + +Definition inst_checker (pm: path_map) (alive por: Regset.t) (i: instruction): option unit := + match iinst_checker pm alive i with + | Some res => + ASSERT Regset.subset por (fst res) IN + exit_checker pm por (snd res) tt + | _ => + ASSERT Regset.subset por alive IN + final_inst_checker pm alive por i + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (alive por: Regset.t) (i: instruction): + inst_checker pm alive por i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + unfold inst_checker. + destruct (iinst_checker pm alive i) as [[alive0 pc0]|] eqn: CHECK1; simpl. + - simpl; intros CHECK2 PC. eapply wf_last_node; eauto. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK2 CHECK1; clear CHECK1 CHECK2; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros PC CHECK1 CHECK2. + intros; exploit exit_checker_res; eauto. + intros X; inversion X. intros; subst; eauto. + - simpl; intros CHECK2 PC. eapply final_inst_checker_wellformed; eauto. + generalize CHECK2. clear CHECK2. inversion_ASSERT. try_simplify_someHyps. Qed. Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := SOME res <- ipath_checker (path.(psize)) f pm (path.(input_regs)) pc IN SOME i <- f.(fn_code)!(snd res) IN - inst_checker pm (fst res) i. + inst_checker pm (fst res) (path.(pre_output_regs)) i. Lemma path_checker_wellformed f pm pc path: path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. diff --git a/scheduling/RTLpathLivegenaux.ml b/scheduling/RTLpathLivegenaux.ml index ab921954..9b93bc32 100644 --- a/scheduling/RTLpathLivegenaux.ml +++ b/scheduling/RTLpathLivegenaux.ml @@ -99,7 +99,7 @@ let get_path_map code entry join_points = dig_path_rec n' end | None -> Some ({ psize = (Camlcoq.Nat.of_int !psize); - input_regs = Regset.empty; output_regs = Regset.empty }, + input_regs = Regset.empty; pre_output_regs = Regset.empty; output_regs = Regset.empty }, !path_successors @ successors_inst inst) end else None @@ -217,41 +217,50 @@ let analyze f = let rec traverse code n size = let inst = get_some @@ PTree.get n code in - if (size == 0) then inst + if (size == 0) then (inst, n) else let n' = get_some @@ predicted_successor inst in traverse code n' (size-1) -let get_outputs liveness code n pi = - let last_instruction = traverse code n (Camlcoq.Nat.to_int pi.psize) in +let get_outputs liveness f n pi = + let (last_instruction, pc_last) = traverse f.fn_code n (Camlcoq.Nat.to_int pi.psize) in let path_last_successors = successors_inst last_instruction in let list_input_regs = List.map ( fun n -> get_some @@ PTree.get n liveness ) path_last_successors in - List.fold_left Regset.union Regset.empty list_input_regs + let outputs = List.fold_left Regset.union Regset.empty list_input_regs in + let por = match last_instruction with (* see RTLpathLivegen.final_inst_checker *) + | Icall (_, _, _, res, _) -> Regset.remove res outputs + | Ibuiltin (_, _, res, _) -> Liveness.reg_list_dead (AST.params_of_builtin_res res) outputs + | Itailcall (_, _, _) | Ireturn _ -> + assert (outputs = Regset.empty); (* defensive check for performance *) + outputs + | _ -> outputs + in (por, outputs) let set_pathmap_liveness f pm = let liveness = analyze f in let new_pm = ref PTree.empty in - let code = f.fn_code in begin debug "Liveness: "; print_ptree_regset liveness; debug "\n"; List.iter (fun (n, pi) -> let inputs = get_some @@ PTree.get n liveness in - let outputs = get_outputs liveness code n pi in + let (por, outputs) = get_outputs liveness f n pi in new_pm := PTree.set n - {psize=pi.psize; input_regs=inputs; output_regs=outputs} !new_pm + {psize=pi.psize; input_regs=inputs; pre_output_regs=por; output_regs=outputs} !new_pm ) (PTree.elements pm); !new_pm end let print_path_info pi = begin debug "(psize=%d; " (Camlcoq.Nat.to_int pi.psize); - debug "input_regs="; + debug "\ninput_regs="; print_regset pi.input_regs; - debug "; output_regs="; + debug "\n; pre_output_regs="; + print_regset pi.pre_output_regs; + debug "\n; output_regs="; print_regset pi.output_regs; - debug ")" + debug ")\n" end let print_path_map path_map = begin diff --git a/scheduling/RTLpathLivegenproof.v b/scheduling/RTLpathLivegenproof.v index c6125985..b02400bf 100644 --- a/scheduling/RTLpathLivegenproof.v +++ b/scheduling/RTLpathLivegenproof.v @@ -280,34 +280,22 @@ Proof. intuition. - (* Iload *) inversion_ASSERT; try_simplify_someHyps. - destruct t. (* TODO - simplify that proof ? *) - + inversion_SOME a0. intros EVAL. - erewrite <- eqlive_reg_listmem; eauto. - try_simplify_someHyps. - inversion_SOME v; try_simplify_someHyps. - repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. + destruct t. + inversion_SOME a0. intros EVAL. + erewrite <- eqlive_reg_listmem; eauto. + try_simplify_someHyps. + inversion_SOME v; try_simplify_someHyps. + repeat (econstructor; simpl; eauto). + 2: + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto; + destruct (eval_addressing _ _ _ _); + try destruct (Memory.Mem.loadv _ _ _); + try (intros; inv H1; repeat (econstructor; simpl; eauto)). + all: + eapply eqlive_reg_update; + eapply eqlive_reg_monotonic; eauto; + intros r0; rewrite regset_add_spec; intuition. - + erewrite <- (eqlive_reg_listmem _ _ rs1 rs2); eauto. - destruct (eval_addressing _ _ _ _). - * destruct (Memory.Mem.loadv _ _ _). - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - ** intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - * intros. inv H1. repeat (econstructor; simpl; eauto). - eapply eqlive_reg_update. - eapply eqlive_reg_monotonic; eauto. - intros r0; rewrite regset_add_spec. - intuition. - (* Istore *) (repeat inversion_ASSERT); try_simplify_someHyps. inversion_SOME a0. intros EVAL. @@ -501,12 +489,23 @@ Proof. intros H; erewrite (EQLIVE r); eauto. Qed. +Lemma final_inst_checker_from_iinst_checker i sp rs m st pm alive por: + istep ge i sp rs m = Some st -> + final_inst_checker pm alive por i = None. +Proof. + destruct i; simpl; try congruence. +Qed. + +(* is it useful ? Lemma inst_checker_from_iinst_checker i sp rs m st pm alive: istep ge i sp rs m = Some st -> inst_checker pm alive i = (SOME res <- iinst_checker pm alive i IN exit_checker pm (fst res) (snd res) tt). Proof. - destruct i; simpl; try congruence. + unfold inst_checker. + destruct (iinst_checker pm alive i); simpl; auto. + destruct i; simpl; try congruence. Qed. +*) Lemma exit_checker_eqlive_ext1 (pm: path_map) (alive: Regset.t) (pc: node) r rs1 rs2: exit_checker pm (Regset.add r alive) pc tt = Some tt -> @@ -586,16 +585,17 @@ Proof. * intuition. eapply IHtbl; eauto. Qed. -Lemma inst_checker_eqlive (f: function) sp alive pc i rs1 rs2 m stk1 stk2 t s1: +Lemma final_inst_checker_eqlive (f: function) sp alive por pc i rs1 rs2 m stk1 stk2 t s1: list_forall2 eqlive_stackframes stk1 stk2 -> eqlive_reg (ext alive) rs1 rs2 -> + Regset.Subset por alive -> liveness_ok_function f -> (fn_code f) ! pc = Some i -> path_last_step ge pge stk1 f sp pc rs1 m t s1 -> - inst_checker (fn_path f) alive i = Some tt -> + final_inst_checker (fn_path f) alive por i = Some tt -> exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. Proof. - intros STACKS EQLIVE LIVENESS PC; + intros STACKS EQLIVE SUB LIVENESS PC; destruct 1 as [i' sp pc rs1 m st1| sp pc rs1 m sig ros args res pc' fd| st1 pc rs1 m sig ros args fd m'| @@ -604,28 +604,12 @@ Proof. st1 pc rs1 m optr m']; try_simplify_someHyps. + (* istate *) - intros PC ISTEP. erewrite inst_checker_from_iinst_checker; eauto. - inversion_SOME res. - intros. - destruct (icontinue st1) eqn: CONT. - - (* CONT => true *) - exploit iinst_checker_eqlive; eauto. - destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - exploit exit_checker_eqlive; eauto. - intros (path & PATH & EQLIVE2). - eapply eqlive_states_intro; eauto. - erewrite <- iinst_checker_istep_continue; eauto. - - (* CONT => false *) - intros; exploit iinst_checker_eqlive_stopped; eauto. - destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). - repeat (econstructor; simpl; eauto). - rewrite <- MEM, <- PC2. - eapply eqlive_states_intro; eauto. + intros PC ISTEP. erewrite final_inst_checker_from_iinst_checker; eauto. + congruence. + (* Icall *) repeat inversion_ASSERT. intros. exploit exit_checker_eqlive_ext1; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Icall; eauto. @@ -645,6 +629,7 @@ Proof. + (* Ibuiltin *) repeat inversion_ASSERT. intros. exploit exit_checker_eqlive_builtin_res; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Ibuiltin; eauto. @@ -654,6 +639,7 @@ Proof. + (* Ijumptable *) repeat inversion_ASSERT. intros. exploit exit_list_checker_eqlive; eauto. + eapply eqlive_reg_monotonic; eauto. intros (path & PATH & EQLIVE2). eexists; split. - eapply exec_Ijumptable; eauto. @@ -669,6 +655,44 @@ Proof. * eapply eqlive_states_return; eauto. Qed. +Lemma inst_checker_eqlive (f: function) sp alive por pc i rs1 rs2 m stk1 stk2 t s1: + list_forall2 eqlive_stackframes stk1 stk2 -> + eqlive_reg (ext alive) rs1 rs2 -> + liveness_ok_function f -> + (fn_code f) ! pc = Some i -> + path_last_step ge pge stk1 f sp pc rs1 m t s1 -> + inst_checker (fn_path f) alive por i = Some tt -> + exists s2, path_last_step ge pge stk2 f sp pc rs2 m t s2 /\ eqlive_states s1 s2. +Proof. + unfold inst_checker; + intros STACKS EQLIVE LIVENESS PC. + destruct (iinst_checker (fn_path f) alive i) as [res|] eqn: IICHECKER. + + destruct 1 as [i' sp pc rs1 m st1| | | | | ]; + try_simplify_someHyps. + intros IICHECKER PC ISTEP. inversion_ASSERT. + intros. + destruct (icontinue st1) eqn: CONT. + - (* CONT => true *) + exploit iinst_checker_eqlive; eauto. + destruct 1 as (st2 & ISTEP2 & [CONT' PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + apply Regset.subset_2 in H. + exploit exit_checker_eqlive; eauto. + eapply eqlive_reg_monotonic; eauto. + intros (path & PATH & EQLIVE2). + eapply eqlive_states_intro; eauto. + erewrite <- iinst_checker_istep_continue; eauto. + - (* CONT => false *) + intros; exploit iinst_checker_eqlive_stopped; eauto. + destruct 1 as (path & st2 & PATH & ISTEP2 & [CONT2 PC2 RS MEM]). + repeat (econstructor; simpl; eauto). + rewrite <- MEM, <- PC2. + eapply eqlive_states_intro; eauto. + + inversion_ASSERT. + intros; exploit final_inst_checker_eqlive; eauto. +Qed. + Lemma path_step_eqlive path stk1 f sp rs1 m pc t s1 stk2 rs2: path_step ge pge (psize path) stk1 f sp rs1 m pc t s1 -> list_forall2 eqlive_stackframes stk1 stk2 -> diff --git a/scheduling/RTLpathSE_impl.v b/scheduling/RTLpathSE_impl.v index 38930a75..12aba56b 100644 --- a/scheduling/RTLpathSE_impl.v +++ b/scheduling/RTLpathSE_impl.v @@ -7,6 +7,7 @@ Require Import RTL RTLpath. Require Import Errors. Require Import RTLpathSE_theory RTLpathLivegenproof. Require Import Axioms RTLpathSE_simu_specs. +Require Import RTLpathSE_simplify. Local Open Scope error_monad_scope. Local Open Scope option_monad_scope. @@ -22,7 +23,7 @@ Import ListNotations. Local Open Scope list_scope. Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := RET tt. (* TO REMOVE DEBUG INFO *) -(* Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := DO s <~ k x;; println ("DEBUG simu_check:" +; s). (* TO INSERT DEBUG INFO *) *) +(*Definition XDEBUG {A} (x:A) (k: A -> ?? pstring): ?? unit := DO s <~ k x;; println ("DEBUG simu_check:" +; s). (* TO INSERT DEBUG INFO *)*) Definition DEBUG (s: pstring): ?? unit := XDEBUG tt (fun _ => RET s). @@ -291,6 +292,15 @@ Definition hSop (op:operation) (lhsv: list_hsval): ?? hsval := DO hv <~ hSop_hcodes op lhsv;; hC_hsval {| hdata:=HSop op lhsv unknown_hid; hcodes :=hv |}. +Lemma hSop_fSop_correct op lhsv: + WHEN hSop op lhsv ~> hv THEN forall ge sp rs0 m0, + seval_hsval ge sp hv rs0 m0 = seval_hsval ge sp (fSop op lhsv) rs0 m0. +Proof. + wlp_simplify. +Qed. +Global Opaque hSop. +Local Hint Resolve hSop_fSop_correct: wlp_raw. + Lemma hSop_correct op lhsv: WHEN hSop op lhsv ~> hv THEN forall ge sp rs0 m0 lsv sm m (MEM: seval_smem ge sp sm rs0 m0 = Some m) @@ -298,12 +308,11 @@ Lemma hSop_correct op lhsv: (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), sval_refines ge sp rs0 m0 hv (Sop op lsv sm). Proof. - wlp_simplify. - rewrite <- H, MEM, LR. - destruct (seval_list_sval _ _ lsv _); try congruence. - eapply op_valid_pointer_eq; eauto. + generalize fSop_correct; simpl. + intros X. + wlp_xsimplify ltac:(intuition eauto with wlp wlp_raw). + erewrite H, X; eauto. Qed. -Global Opaque hSop. Local Hint Resolve hSop_correct: wlp. Definition hSload_hcodes (hsm: hsmem) (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) (lhsv: list_hsval):= @@ -430,6 +439,68 @@ Qed. Global Opaque hlist_args. Local Hint Resolve hlist_args_correct: wlp. +(** Convert a "fake" hash-consed term into a "real" hash-consed term *) + +Fixpoint fsval_proj hsv: ?? hsval := + match hsv with + | HSinput r hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then hSinput r (* was not yet really hash-consed *) + else RET hsv (* already hash-consed *) + | HSop op hl hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then (* was not yet really hash-consed *) + DO hl' <~ fsval_list_proj hl;; + hSop op hl' + else RET hsv (* already hash-consed *) + | HSload hm t chk addr hl _ => RET hsv (* FIXME ? *) + end +with fsval_list_proj hsl: ?? list_hsval := + match hsl with + | HSnil hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then hSnil() (* was not yet really hash-consed *) + else RET hsl (* already hash-consed *) + | HScons hv hl hc => + DO b <~ phys_eq hc unknown_hid;; + if b + then (* was not yet really hash-consed *) + DO hv' <~ fsval_proj hv;; + DO hl' <~ fsval_list_proj hl;; + hScons hv' hl' + else RET hsl (* already hash-consed *) + end. + +Lemma fsval_proj_correct hsv: + WHEN fsval_proj hsv ~> hsv' THEN forall ge sp rs0 m0, + seval_hsval ge sp hsv rs0 m0 = seval_hsval ge sp hsv' rs0 m0. +Proof. + induction hsv using hsval_mut + with (P0 := fun lhsv => + WHEN fsval_list_proj lhsv ~> lhsv' THEN forall ge sp rs0 m0, + seval_list_hsval ge sp lhsv rs0 m0 = seval_list_hsval ge sp lhsv' rs0 m0) + (P1 := fun sm => True); try (wlp_simplify; tauto). + - wlp_xsimplify ltac:(intuition eauto with wlp_raw wlp). + rewrite H, H0; auto. + - wlp_simplify; erewrite H0, H1; eauto. +Qed. +Global Opaque fsval_proj. +Local Hint Resolve fsval_proj_correct: wlp. + +Lemma fsval_list_proj_correct lhsv: + WHEN fsval_list_proj lhsv ~> lhsv' THEN forall ge sp rs0 m0, + seval_list_hsval ge sp lhsv rs0 m0 = seval_list_hsval ge sp lhsv' rs0 m0. +Proof. + induction lhsv; wlp_simplify. + erewrite H0, H1; eauto. +Qed. +Global Opaque fsval_list_proj. +Local Hint Resolve fsval_list_proj_correct: wlp. + + (** ** Assignment of memory *) Definition hslocal_set_smem (hst:hsistate_local) hm := {| hsi_smem := hm; @@ -601,10 +672,14 @@ Definition simplify (rsv: root_sval) (lr: list reg) (hst: hsistate_local): ?? hs match rsv with | Rop op => match is_move_operation op lr with - | Some arg => hsi_sreg_get hst arg (** optimization of Omove *) + | Some arg => hsi_sreg_get hst arg (* optimization of Omove *) | None => - DO lhsv <~ hlist_args hst lr;; - hSop op lhsv + match target_op_simplify op lr hst with + | Some fhv => fsval_proj fhv + | None => + DO lhsv <~ hlist_args hst lr;; + hSop op lhsv + end end | Rload _ chunk addr => DO lhsv <~ hlist_args hst lr;; @@ -620,17 +695,21 @@ Lemma simplify_correct rsv lr hst: Proof. destruct rsv; simpl; auto. - (* Rop *) - destruct (is_move_operation _ _) eqn: Hmove; wlp_simplify. - + exploit is_move_operation_correct; eauto. + destruct (is_move_operation _ _) eqn: Hmove. + { wlp_simplify; exploit is_move_operation_correct; eauto. intros (Hop & Hlsv); subst; simpl in *. simplify_SOME z. * erewrite H; eauto. * try_simplify_someHyps; congruence. - * congruence. - + clear Hmove. - generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. - destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. - intro H0; clear H0; simplify_SOME z; congruence. (* absurd case *) + * congruence. } + destruct (target_op_simplify _ _ _) eqn: Htarget_op_simp; wlp_simplify. + { destruct (seval_list_sval _ _ _) eqn: OKlist; try congruence. + destruct (seval_smem _ _ _ _ _) eqn: OKmem; try congruence. + rewrite <- H; exploit target_op_simplify_correct; eauto. } + clear Htarget_op_simp. + generalize (H0 ge sp rs0 m0 (list_sval_inj (map (si_sreg st) lr)) (si_smem st)); clear H0. + destruct (seval_smem ge sp (si_smem st) rs0 m0) as [m|] eqn:X; eauto. + intro H0; clear H0; simplify_SOME z; congruence. (* absurd case *) - (* Rload *) destruct trap; wlp_simplify. erewrite H0; eauto. @@ -740,12 +819,52 @@ Proof. rewrite <- X, sok_local_set_sreg. intuition eauto. - destruct REF; intuition eauto. - generalize REF; intros (OKEQ & _). rewrite OKEQ in * |-; erewrite red_PTree_set_refines; eauto. -Qed. + Qed. Global Opaque hslocal_set_sreg. Local Hint Resolve hslocal_set_sreg_correct: wlp. (** ** Execution of one instruction *) +(* TODO gourdinl + * This is just useful for debugging fake values hashcode projection *) +Fixpoint check_no_uhid lhsv := + match lhsv with + | HSnil hc => + DO b <~ phys_eq hc unknown_hid;; + assert_b (negb b) "fail no uhid";; + RET tt + | HScons hsv lhsv' hc => + DO b <~ phys_eq hc unknown_hid;; + assert_b (negb b) "fail no uhid";; + check_no_uhid lhsv' + end. + +Definition cbranch_expanse (prev: hsistate_local) (cond: condition) (args: list reg): ?? (condition * list_hsval) := + match target_cbranch_expanse prev cond args with + | Some (cond', vargs) => + DO vargs' <~ fsval_list_proj vargs;; + RET (cond', vargs') + | None => + DO vargs <~ hlist_args prev args ;; + RET (cond, vargs) + end. + +Lemma cbranch_expanse_correct hst c l: + WHEN cbranch_expanse hst c l ~> r THEN forall ge sp rs0 m0 st + (LREF : hsilocal_refines ge sp rs0 m0 hst st) + (OK: hsok_local ge sp rs0 m0 hst), + seval_condition ge sp (fst r) (hsval_list_proj (snd r)) (si_smem st) rs0 m0 = + seval_condition ge sp c (list_sval_inj (map (si_sreg st) l)) (si_smem st) rs0 m0. +Proof. + unfold cbranch_expanse. + destruct (target_cbranch_expanse _ _ _) eqn: TARGET; wlp_simplify; + unfold seval_condition; erewrite <- H; eauto. + destruct p as [c' l']; simpl. + exploit target_cbranch_expanse_correct; eauto. +Qed. +Local Hint Resolve cbranch_expanse_correct: wlp. +Global Opaque cbranch_expanse. + Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) := match i with | Inop pc' => @@ -761,13 +880,13 @@ Definition hsiexec_inst (i: instruction) (hst: hsistate): ?? (option hsistate) : RET (Some (hsist_set_local hst pc' next)) | Icond cond args ifso ifnot _ => let prev := hst.(hsi_local) in - DO vargs <~ hlist_args prev args ;; + DO res <~ cbranch_expanse prev cond args;; + let (cond, vargs) := res in let ex := {| hsi_cond:=cond; hsi_scondargs:=vargs; hsi_elocal := prev; hsi_ifso := ifso |} in RET (Some {| hsi_pc := ifnot; hsi_exits := ex::hst.(hsi_exits); hsi_local := prev |}) - | _ => RET None (* TODO jumptable ? *) + | _ => RET None end. - Remark hsiexec_inst_None_correct i hst: WHEN hsiexec_inst i hst ~> o THEN forall st, o = None -> siexec_inst i st = None. Proof. @@ -794,6 +913,52 @@ Qed. Local Hint Resolve hsist_set_local_correct_stat: core. +Lemma hsiexec_cond_noexp (hst: hsistate): forall l c0 n n0, + WHEN DO res <~ + (DO vargs <~ hlist_args (hsi_local hst) l;; RET ((c0, vargs)));; + (let (cond, vargs) := res in + RET (Some + {| + hsi_pc := n0; + hsi_exits := {| + hsi_cond := cond; + hsi_scondargs := vargs; + hsi_elocal := hsi_local hst; + hsi_ifso := n |} :: hsi_exits hst; + hsi_local := hsi_local hst |})) ~> o0 + THEN (forall (hst' : hsistate) (st : sistate), + o0 = Some hst' -> + exists st' : sistate, + Some + {| + si_pc := n0; + si_exits := {| + si_cond := c0; + si_scondargs := list_sval_inj + (map (si_sreg (si_local st)) l); + si_elocal := si_local st; + si_ifso := n |} :: si_exits st; + si_local := si_local st |} = Some st' /\ + (hsistate_refines_stat hst st -> hsistate_refines_stat hst' st') /\ + (forall (ge : RTL.genv) (sp : val) (rs0 : regset) (m0 : mem), + hsistate_refines_dyn ge sp rs0 m0 hst st -> + hsistate_refines_dyn ge sp rs0 m0 hst' st')). +Proof. + intros. + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + - unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. + constructor; simpl; eauto. + constructor. + - destruct H0 as (EXREF & LREF & NEST). + split. + + constructor; simpl; auto. + constructor; simpl; auto. + intros; erewrite seval_condition_refines; eauto. + + split; simpl; auto. + destruct NEST as [|st0 se lse TOP NEST]; + econstructor; simpl; auto; constructor; auto. +Qed. + Lemma hsiexec_inst_correct i hst: WHEN hsiexec_inst i hst ~> o THEN forall hst' st, o = Some hst' -> @@ -801,29 +966,33 @@ Lemma hsiexec_inst_correct i hst: /\ (forall (REF:hsistate_refines_stat hst st), hsistate_refines_stat hst' st') /\ (forall ge sp rs0 m0 (REF:hsistate_refines_dyn ge sp rs0 m0 hst st), hsistate_refines_dyn ge sp rs0 m0 hst' st'). Proof. - destruct i; simpl; wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + destruct i; simpl; + try (wlp_simplify; try_simplify_someHyps; eexists; intuition eauto; fail). - (* refines_dyn Iop *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. generalize (sok_local_set_sreg_simp (Rop o)); simpl; eauto. - (* refines_dyn Iload *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. generalize (sok_local_set_sreg_simp (Rload t0 m a)); simpl; eauto. - (* refines_dyn Istore *) + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. eapply hsist_set_local_correct_dyn; eauto. unfold sok_local; simpl; intuition. - (* refines_stat Icond *) - unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. - constructor; simpl; eauto. - constructor. - - (* refines_dyn Icond *) - destruct REF as (EXREF & LREF & NEST). - split. - + constructor; simpl; auto. - constructor; simpl; auto. - intros; erewrite seval_condition_refines; eauto. - + split; simpl; auto. - destruct NEST as [|st0 se lse TOP NEST]; - econstructor; simpl; auto; constructor; auto. + wlp_simplify; try_simplify_someHyps; eexists; intuition eauto. + + unfold hsistate_refines_stat, hsiexits_refines_stat in *; simpl; intuition. + constructor; simpl; eauto. + constructor. + + destruct REF as (EXREF & LREF & NEST). + split. + * constructor; simpl; auto. + constructor; simpl; auto. + intros; erewrite seval_condition_refines; eauto. + * split; simpl; auto. + destruct NEST as [|st0 se lse TOP NEST]; + econstructor; simpl; auto; constructor; auto. Qed. Global Opaque hsiexec_inst. Local Hint Resolve hsiexec_inst_correct: wlp. @@ -1149,22 +1318,6 @@ Qed. Global Opaque PTree_frame_eq_check. Local Hint Resolve PTree_frame_eq_check_correct: wlp. -Definition hsilocal_simu_check hst1 hst2 : ?? unit := - DEBUG("? last check");; - phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_simu_check: hsi_smem sets aren't equiv";; - PTree_eq_check (hsi_sreg hst1) (hsi_sreg hst2);; - Sets.assert_list_incl mk_hash_params (hsi_ok_lsval hst2) (hsi_ok_lsval hst1);; - DEBUG("=> last check: OK"). - -Lemma hsilocal_simu_check_correct hst1 hst2: - WHEN hsilocal_simu_check hst1 hst2 ~> _ THEN - hsilocal_simu_spec None hst1 hst2. -Proof. - unfold hsilocal_simu_spec; wlp_simplify. -Qed. -Hint Resolve hsilocal_simu_check_correct: wlp. -Global Opaque hsilocal_simu_check. - Definition hsilocal_frame_simu_check frame hst1 hst2 : ?? unit := DEBUG("? frame check");; phys_check (hsi_smem hst2) (hsi_smem hst1) "hsilocal_frame_simu_check: hsi_smem sets aren't equiv";; @@ -1192,7 +1345,7 @@ Local Hint Resolve regset_elements_in: core. Lemma hsilocal_frame_simu_check_correct hst1 hst2 alive: WHEN hsilocal_frame_simu_check (Regset.elements alive) hst1 hst2 ~> _ THEN - hsilocal_simu_spec (Some alive) hst1 hst2. + hsilocal_simu_spec alive hst1 hst2. Proof. unfold hsilocal_simu_spec; wlp_simplify. symmetry; eauto. Qed. @@ -1246,13 +1399,13 @@ Qed. Hint Resolve hsiexits_simu_check_correct: wlp. Global Opaque hsiexits_simu_check. -Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsistate) := +Definition hsistate_simu_check (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsistate) := hsiexits_simu_check dm f (hsi_exits hst1) (hsi_exits hst2);; - hsilocal_simu_check (hsi_local hst1) (hsi_local hst2). + hsilocal_frame_simu_check (Regset.elements outframe) (hsi_local hst1) (hsi_local hst2). -Lemma hsistate_simu_check_correct dm f hst1 hst2: - WHEN hsistate_simu_check dm f hst1 hst2 ~> _ THEN - hsistate_simu_spec dm f hst1 hst2. +Lemma hsistate_simu_check_correct dm f outframe hst1 hst2: + WHEN hsistate_simu_check dm f outframe hst1 hst2 ~> _ THEN + hsistate_simu_spec dm f outframe hst1 hst2. Proof. unfold hsistate_simu_spec; wlp_simplify. Qed. @@ -1386,18 +1539,18 @@ Qed. Hint Resolve sfval_simu_check_correct: wlp. Global Opaque sfval_simu_check. -Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_check dm f (hinternal hst1) (hinternal hst2);; +Definition hsstate_simu_check (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsstate) := + hsistate_simu_check dm f outframe (hinternal hst1) (hinternal hst2);; sfval_simu_check dm f (hsi_pc hst1) (hsi_pc hst2) (hfinal hst1) (hfinal hst2). -Lemma hsstate_simu_check_correct dm f hst1 hst2: - WHEN hsstate_simu_check dm f hst1 hst2 ~> _ THEN - hsstate_simu_spec dm f hst1 hst2. +Lemma hsstate_simu_check_correct dm f outframe hst1 hst2: + WHEN hsstate_simu_check dm f outframe hst1 hst2 ~> _ THEN + hsstate_simu_spec dm f outframe hst1 hst2. Proof. unfold hsstate_simu_spec; wlp_simplify. Qed. Hint Resolve hsstate_simu_check_correct: wlp. -Global Opaque hsstate_simu_check. +Global Opaque hsstate_simu_check. Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpath.function) (m: node * node): ?? unit := let (pc2, pc1) := m in @@ -1411,8 +1564,10 @@ Definition simu_check_single (dm: PTree.t node) (f: RTLpath.function) (tf: RTLpa DO hst1 <~ hsexec f pc1;; XDEBUG pc2 (fun pc => DO name_pc <~ string_of_Z (Zpos pc);; RET ("entry-point of output superblock: " +; name_pc)%string);; DO hst2 <~ hsexec tf pc2;; + DO path <~ some_or_fail ((fn_path f)!pc1) "simu_check_single.internal_error.1";; + let outframe := path.(pre_output_regs) in (* comparing the executions *) - hsstate_simu_check dm f hst1 hst2. + hsstate_simu_check dm f outframe hst1 hst2. Lemma simu_check_single_correct dm tf f pc1 pc2: WHEN simu_check_single dm f tf (pc2, pc1) ~> _ THEN @@ -1423,7 +1578,7 @@ Proof. intros (st2 & SEXEC2 & REF2). try_simplify_someHyps. exploit H3; clear H3. 1-3: wlp_simplify. intros (st3 & SEXEC3 & REF3). try_simplify_someHyps. - eexists. split; eauto. + eexists. eexists. split; eauto. split; eauto. intros ctx. eapply hsstate_simu_spec_correct; eauto. Qed. @@ -1506,4 +1661,4 @@ Proof. destruct (unsafe_coerce (aux_simu_check dm f tf)) as [[|]|] eqn:Hres; simpl; try discriminate. intros; eapply aux_simu_check_correct; eauto. eapply unsafe_coerce_not_really_correct; eauto. -Qed.
\ No newline at end of file +Qed. diff --git a/scheduling/RTLpathSE_simu_specs.v b/scheduling/RTLpathSE_simu_specs.v index c9e272c0..c6a4d409 100644 --- a/scheduling/RTLpathSE_simu_specs.v +++ b/scheduling/RTLpathSE_simu_specs.v @@ -12,16 +12,17 @@ Local Open Scope error_monad_scope. Local Open Scope option_monad_scope. Require Export Impure.ImpHCons. +Import HConsing. Import ListNotations. Local Open Scope list_scope. (** * Auxilary notions on simulation tests *) -Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := +Definition silocal_simu (dm: PTree.t node) (f: RTLpath.function) outframe (sl1 sl2: sistate_local) (ctx: simu_proof_context f): Prop := forall is1, ssem_local (the_ge1 ctx) (the_sp ctx) sl1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) -> exists is2, ssem_local (the_ge2 ctx) (the_sp ctx) sl2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. (* a kind of negation of sabort_local *) Definition sok_local (ge: RTL.genv) (sp:val) (rs0: regset) (m0: mem) (st: sistate_local): Prop := @@ -36,7 +37,7 @@ Proof. intuition congruence. Qed. -Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof_context f) (se1 se2: sistate_exit) := +Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) outframe (ctx: simu_proof_context f) (se1 se2: sistate_exit) := (sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1) -> (seval_condition (the_ge1 ctx) (the_sp ctx) (si_cond se1) (si_scondargs se1) (si_smem (si_elocal se1)) (the_rs0 ctx) (the_m0 ctx)) = @@ -47,10 +48,10 @@ Definition siexit_simu (dm: PTree.t node) (f: RTLpath.function) (ctx: simu_proof ssem_exit (the_ge1 ctx) (the_sp ctx) se1 (the_rs0 ctx) (the_m0 ctx) (irs is1) (imem is1) (ipc is1) -> exists is2, ssem_exit (the_ge2 ctx) (the_sp ctx) se2 (the_rs0 ctx) (the_m0 ctx) (irs is2) (imem is2) (ipc is2) - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. -Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := - list_forall2 (siexit_simu dm f ctx) lse1 lse2. +Definition siexits_simu (dm: PTree.t node) (f: RTLpath.function) outframe (lse1 lse2: list sistate_exit) (ctx: simu_proof_context f) := + list_forall2 (siexit_simu dm f outframe ctx) lse1 lse2. (** * Implementation of Data-structure use in Hash-consing *) @@ -304,6 +305,66 @@ Inductive hfinal_refines: hsfval -> sfval -> Prop := End HFINAL_REFINES. +(* TODO gourdinl Leave this here ? *) +Section FAKE_HSVAL. +(* BEGIN "fake" hsval without real hash-consing *) +(* TODO: + 1) put these definitions elsewhere ? in RTLpathSE_simu_specs.v ? + 2) reuse these definitions in hSinput, hSop, etc + in order to factorize proofs ? +*) + +Definition fSinput (r: reg): hsval := + HSinput r unknown_hid. + +Lemma fSinput_correct r ge sp rs0 m0: (* useless trivial lemma ? *) + sval_refines ge sp rs0 m0 (fSinput r) (Sinput r). +Proof. + auto. +Qed. + +Definition fSop (op:operation) (lhsv: list_hsval): hsval := + HSop op lhsv unknown_hid. + +Lemma fSop_correct op lhsv ge sp rs0 m0 lsv sm m: forall + (MEM: seval_smem ge sp sm rs0 m0 = Some m) + (MVALID: forall b ofs, Mem.valid_pointer m b ofs = Mem.valid_pointer m0 b ofs) + (LR: list_sval_refines ge sp rs0 m0 lhsv lsv), + sval_refines ge sp rs0 m0 (fSop op lhsv) (Sop op lsv sm). +Proof. + intros; simpl. rewrite <- LR, MEM. + destruct (seval_list_sval _ _ _ _); try congruence. + eapply op_valid_pointer_eq; eauto. +Qed. + +Definition fsi_sreg_get (hst: PTree.t hsval) r: hsval := + match PTree.get r hst with + | None => fSinput r + | Some sv => sv + end. + +Lemma fsi_sreg_get_correct hst r ge sp rs0 m0 (f: reg -> sval): forall + (RR: forall r, hsi_sreg_eval ge sp hst r rs0 m0 = seval_sval ge sp (f r) rs0 m0), + sval_refines ge sp rs0 m0 (fsi_sreg_get hst r) (f r). +Proof. + unfold hsi_sreg_eval, hsi_sreg_proj, fsi_sreg_get; intros; simpl. + rewrite <- RR. destruct (hst ! r); simpl; auto. +Qed. + +Definition fSnil: list_hsval := + HSnil unknown_hid. + +(* TODO: Lemma fSnil_correct *) + +Definition fScons (hsv: hsval) (lhsv: list_hsval): list_hsval := + HScons hsv lhsv unknown_hid. + +(* TODO: Lemma fScons_correct *) + +(* END "fake" hsval ... *) + +End FAKE_HSVAL. + Record hsstate := { hinternal:> hsistate; hfinal: hsfval }. @@ -318,9 +379,9 @@ Definition hsstate_refines (hst: hsstate) (st:sstate): Prop := (** ** Specification of the simulation test on [hsistate_local]. It is motivated by [hsilocal_simu_spec_correct theorem] below *) -Definition hsilocal_simu_spec (oalive: option Regset.t) (hst1 hst2: hsistate_local) := +Definition hsilocal_simu_spec (alive: Regset.t) (hst1 hst2: hsistate_local) := List.incl (hsi_ok_lsval hst2) (hsi_ok_lsval hst1) - /\ (forall r, (match oalive with Some alive => Regset.In r alive | _ => True end) -> PTree.get r hst2 = PTree.get r hst1) + /\ (forall r, Regset.In r alive -> PTree.get r hst2 = PTree.get r hst1) /\ hsi_smem hst1 = hsi_smem hst2. Definition seval_sval_partial ge sp rs0 m0 hsv := @@ -368,18 +429,14 @@ Proof. - erewrite MEMOK in OKM. erewrite smem_eval_preserved; eauto. Qed. -Theorem hsilocal_simu_spec_correct hst1 hst2 of ge1 ge2 sp rs0 m0 rs m st1 st2: - hsilocal_simu_spec of hst1 hst2 -> +Theorem hsilocal_simu_spec_correct hst1 hst2 alive ge1 ge2 sp rs0 m0 rs m st1 st2: + hsilocal_simu_spec alive hst1 hst2 -> hsilocal_refines ge1 sp rs0 m0 hst1 st1 -> hsilocal_refines ge2 sp rs0 m0 hst2 st2 -> (forall s, Genv.find_symbol ge1 s = Genv.find_symbol ge2 s) -> ssem_local ge1 sp st1 rs0 m0 rs m -> - match of with - | None => ssem_local ge2 sp st2 rs0 m0 rs m - | Some alive => - let rs' := seval_partial_regset ge2 sp rs0 m0 (hsi_sreg hst2) - in ssem_local ge2 sp st2 rs0 m0 rs' m /\ eqlive_reg (fun r => Regset.In r alive) rs rs' - end. + let rs' := seval_partial_regset ge2 sp rs0 m0 (hsi_sreg hst2) + in ssem_local ge2 sp st2 rs0 m0 rs' m /\ eqlive_reg (fun r => Regset.In r alive) rs rs'. Proof. intros CORE HREF1 HREF2 GFS SEML. refine (modusponens _ _ (ssem_local_refines_hok _ _ _ _ _ _ _ _ _ _) _); eauto. @@ -394,9 +451,8 @@ Proof. rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. erewrite smem_eval_preserved; [| eapply GFS]. rewrite MEMEQ1; auto. } - destruct of as [alive |]. - - constructor. - + constructor; [assumption | constructor; [assumption|]]. + constructor. + + constructor; [assumption | constructor; [assumption|]]. destruct HREF2 as (B & _ & A & _). (** B is used for the auto below. *) assert (forall r : positive, hsi_sreg_eval ge2 sp hst2 r rs0 m0 = seval_sval ge2 sp (si_sreg st2 r) rs0 m0) by auto. @@ -420,17 +476,6 @@ Proof. unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; [|assumption]. rewrite RSEQ. reflexivity. ++ rewrite <- RSEQ. rewrite <- B; [|assumption]. unfold hsi_sreg_eval, hsi_sreg_proj. rewrite <- C; [|assumption]. rewrite HST2. reflexivity. - - constructor; [|constructor]. - + destruct HREF2 as (OKEQ & _ & _). rewrite <- OKEQ in HOK2. apply HOK2. - + destruct HREF2 as (_ & MEMEQ2 & _). destruct HREF1 as (_ & MEMEQ1 & _). - destruct CORE as (_ & _ & MEMEQ3). - rewrite <- MEMEQ2; auto. rewrite <- MEMEQ3. - erewrite smem_eval_preserved; [| eapply GFS]. - rewrite MEMEQ1; auto. - + intro r. destruct HREF2 as (_ & _ & A & _). destruct HREF1 as (_ & _ & B & _). - destruct CORE as (_ & C & _). rewrite <- A; auto. unfold hsi_sreg_eval, hsi_sreg_proj. - rewrite C; [|auto]. erewrite seval_preserved; [| eapply GFS]. - unfold hsi_sreg_eval, hsi_sreg_proj in B; rewrite B; auto. Qed. (** ** Specification of the simulation test on [hsistate_exit]. @@ -438,17 +483,17 @@ Qed. *) Definition hsiexit_simu_spec dm f (hse1 hse2: hsistate_exit) := (exists path, (fn_path f) ! (hsi_ifso hse1) = Some path - /\ hsilocal_simu_spec (Some path.(input_regs)) (hsi_elocal hse1) (hsi_elocal hse2)) + /\ hsilocal_simu_spec path.(input_regs) (hsi_elocal hse1) (hsi_elocal hse2)) /\ dm ! (hsi_ifso hse2) = Some (hsi_ifso hse1) /\ hsi_cond hse1 = hsi_cond hse2 /\ hsi_scondargs hse1 = hsi_scondargs hse2. -Definition hsiexit_simu dm f (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, +Definition hsiexit_simu dm f outframe (ctx: simu_proof_context f) hse1 hse2: Prop := forall se1 se2, hsiexit_refines_stat hse1 se1 -> hsiexit_refines_stat hse2 se2 -> hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. + siexit_simu dm f outframe ctx se1 se2. Lemma hsiexit_simu_spec_nofail dm f hse1 hse2 ge1 ge2 sp rs m: hsiexit_simu_spec dm f hse1 hse2 -> @@ -461,9 +506,9 @@ Proof. eapply hsilocal_simu_spec_nofail; eauto. Qed. -Theorem hsiexit_simu_spec_correct dm f hse1 hse2 ctx: +Theorem hsiexit_simu_spec_correct dm f outframe hse1 hse2 ctx: hsiexit_simu_spec dm f hse1 hse2 -> - hsiexit_simu dm f ctx hse1 hse2. + hsiexit_simu dm f outframe ctx hse1 hse2. Proof. intros SIMUC st1 st2 HREF1 HREF2 HDYN1 HDYN2. assert (SEVALC: @@ -498,13 +543,13 @@ Proof. constructor; [|constructor]; simpl; auto. Qed. -Remark hsiexit_simu_siexit dm f ctx hse1 hse2 se1 se2: - hsiexit_simu dm f ctx hse1 hse2 -> +Remark hsiexit_simu_siexit dm f outframe ctx hse1 hse2 se1 se2: + hsiexit_simu dm f outframe ctx hse1 hse2 -> hsiexit_refines_stat hse1 se1 -> hsiexit_refines_stat hse2 se2 -> hsiexit_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse1 se1 -> hsiexit_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hse2 se2 -> - siexit_simu dm f ctx se1 se2. + siexit_simu dm f outframe ctx se1 se2. Proof. auto. Qed. @@ -513,15 +558,15 @@ Qed. It is motivated by [hsiexit_simu_spec_correct theorem] below *) -Definition hsiexits_simu dm f (ctx: simu_proof_context f) (lhse1 lhse2: list hsistate_exit): Prop := - list_forall2 (hsiexit_simu dm f ctx) lhse1 lhse2. +Definition hsiexits_simu dm f outframe (ctx: simu_proof_context f) (lhse1 lhse2: list hsistate_exit): Prop := + list_forall2 (hsiexit_simu dm f outframe ctx) lhse1 lhse2. Definition hsiexits_simu_spec dm f lhse1 lhse2: Prop := list_forall2 (hsiexit_simu_spec dm f) lhse1 lhse2. -Theorem hsiexits_simu_spec_correct dm f lhse1 lhse2 ctx: +Theorem hsiexits_simu_spec_correct dm f outframe lhse1 lhse2 ctx: hsiexits_simu_spec dm f lhse1 lhse2 -> - hsiexits_simu dm f ctx lhse1 lhse2. + hsiexits_simu dm f outframe ctx lhse1 lhse2. Proof. induction 1; [constructor|]. constructor; [|apply IHlist_forall2; assumption]. @@ -529,8 +574,8 @@ Proof. Qed. -Lemma siexits_simu_all_fallthrough dm f ctx: forall lse1 lse2, - siexits_simu dm f lse1 lse2 ctx -> +Lemma siexits_simu_all_fallthrough dm f outframe ctx: forall lse1 lse2, + siexits_simu dm f outframe lse1 lse2 ctx -> all_fallthrough (the_ge1 ctx) (the_sp ctx) lse1 (the_rs0 ctx) (the_m0 ctx) -> (forall se1, In se1 lse1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> all_fallthrough (the_ge2 ctx) (the_sp ctx) lse2 (the_rs0 ctx) (the_m0 ctx). @@ -545,8 +590,8 @@ Proof. Qed. -Lemma siexits_simu_all_fallthrough_upto dm f ctx lse1 lse2: - siexits_simu dm f lse1 lse2 ctx -> +Lemma siexits_simu_all_fallthrough_upto dm f outframe ctx lse1 lse2: + siexits_simu dm f outframe lse1 lse2 ctx -> forall ext1 lx1, (forall se1, In se1 lx1 -> sok_local (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) (si_elocal se1)) -> all_fallthrough_upto_exit (the_ge1 ctx) (the_sp ctx) ext1 lx1 lse1 (the_rs0 ctx) (the_m0 ctx) -> @@ -570,14 +615,14 @@ Proof. Qed. -Lemma hsiexits_simu_siexits dm f ctx lhse1 lhse2: - hsiexits_simu dm f ctx lhse1 lhse2 -> +Lemma hsiexits_simu_siexits dm f outframe ctx lhse1 lhse2: + hsiexits_simu dm f outframe ctx lhse1 lhse2 -> forall lse1 lse2, hsiexits_refines_stat lhse1 lse1 -> hsiexits_refines_stat lhse2 lse2 -> hsiexits_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse1 lse1 -> hsiexits_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) lhse2 lse2 -> - siexits_simu dm f lse1 lse2 ctx. + siexits_simu dm f outframe lse1 lse2 ctx. Proof. induction 1. - intros. inv H. inv H0. constructor. @@ -591,16 +636,16 @@ Qed. It is motivated by [hsistate_simu_spec_correct theorem] below *) -Definition hsistate_simu_spec dm f (hse1 hse2: hsistate) := +Definition hsistate_simu_spec dm f outframe (hse1 hse2: hsistate) := list_forall2 (hsiexit_simu_spec dm f) (hsi_exits hse1) (hsi_exits hse2) - /\ hsilocal_simu_spec None (hsi_local hse1) (hsi_local hse2). + /\ hsilocal_simu_spec outframe (hsi_local hse1) (hsi_local hse2). -Definition hsistate_simu dm f (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, +Definition hsistate_simu dm f outframe (hst1 hst2: hsistate) (ctx: simu_proof_context f): Prop := forall st1 st2, hsistate_refines_stat hst1 st1 -> hsistate_refines_stat hst2 st2 -> hsistate_refines_dyn (the_ge1 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst1 st1 -> hsistate_refines_dyn (the_ge2 ctx) (the_sp ctx) (the_rs0 ctx) (the_m0 ctx) hst2 st2 -> - sistate_simu dm f st1 st2 ctx. + sistate_simu dm f outframe st1 st2 ctx. Lemma list_forall2_nth_error {A} (l1 l2: list A) P: list_forall2 P l1 l2 -> @@ -644,9 +689,9 @@ Proof. rewrite H0; auto. Qed. -Theorem hsistate_simu_spec_correct dm f hst1 hst2 ctx: - hsistate_simu_spec dm f hst1 hst2 -> - hsistate_simu dm f hst1 hst2 ctx. +Theorem hsistate_simu_spec_correct dm f outframe hst1 hst2 ctx: + hsistate_simu_spec dm f outframe hst1 hst2 -> + hsistate_simu dm f outframe hst1 hst2 ctx. Proof. intros (ESIMU & LSIMU) st1 st2 (PCREF1 & EREF1) (PCREF2 & EREF2) DREF1 DREF2 is1 SEMI. destruct DREF1 as (DEREF1 & LREF1 & NESTED). destruct DREF2 as (DEREF2 & LREF2 & _). @@ -654,23 +699,27 @@ Proof. unfold ssem_internal in SEMI. destruct (icontinue _) eqn:ICONT. - destruct SEMI as (SSEML & PCEQ & ALLFU). exploit hsilocal_simu_spec_correct; eauto; [apply ctx|]. simpl. intro SSEML2. - exists (mk_istate (icontinue is1) (si_pc st2) (irs is1) (imem is1)). constructor. - + unfold ssem_internal. simpl. rewrite ICONT. constructor; [assumption | constructor; [reflexivity |]]. + exists (mk_istate (icontinue is1) (si_pc st2) (seval_partial_regset (the_ge2 ctx) (the_sp ctx) + (the_rs0 ctx) (the_m0 ctx) (hsi_local hst2)) (imem is1)). constructor. + + unfold ssem_internal. simpl. rewrite ICONT. + destruct SSEML2 as [SSEMLP EQLIVE]. + constructor; [assumption | constructor; [reflexivity |]]. eapply siexits_simu_all_fallthrough; eauto. * eapply hsiexits_simu_siexits; eauto. * eapply nested_sok_prop; eauto. eapply ssem_local_sok; eauto. - + unfold istate_simu. rewrite ICONT. constructor; [simpl; assumption | constructor; [| reflexivity]]. - constructor. + + unfold istate_simu. rewrite ICONT. + destruct SSEML2 as [SSEMLP EQLIVE]. + constructor; simpl; auto. - destruct SEMI as (ext & lx & SSEME & ALLFU). - assert (SESIMU: siexits_simu dm f (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). + assert (SESIMU: siexits_simu dm f outframe (si_exits st1) (si_exits st2) ctx) by (eapply hsiexits_simu_siexits; eauto). exploit siexits_simu_all_fallthrough_upto; eauto. * destruct ALLFU as (ITAIL & ALLF). exploit nested_sok_tail; eauto. intros NESTED2. inv NESTED2. destruct SSEME as (_ & SSEML & _). eapply ssem_local_sok in SSEML. eapply nested_sok_prop; eauto. * intros (ext2 & lx2 & ALLFU2 & LENEQ). - assert (EXTSIMU: siexit_simu dm f ctx ext ext2). { + assert (EXTSIMU: siexit_simu dm f outframe ctx ext ext2). { eapply list_forall2_nth_error; eauto. - destruct ALLFU as (ITAIL & _). eapply is_tail_nth_error; eauto. - destruct ALLFU2 as (ITAIL & _). eapply is_tail_nth_error in ITAIL. @@ -858,18 +907,18 @@ Qed. It is motivated by [hsstate_simu_spec_correct theorem] below *) -Definition hsstate_simu_spec (dm: PTree.t node) (f: RTLpath.function) (hst1 hst2: hsstate) := - hsistate_simu_spec dm f (hinternal hst1) (hinternal hst2) +Definition hsstate_simu_spec (dm: PTree.t node) (f: RTLpath.function) outframe (hst1 hst2: hsstate) := + hsistate_simu_spec dm f outframe (hinternal hst1) (hinternal hst2) /\ hfinal_simu_spec dm f (hsi_pc (hinternal hst1)) (hsi_pc (hinternal hst2)) (hfinal hst1) (hfinal hst2). -Definition hsstate_simu dm f (hst1 hst2: hsstate) ctx: Prop := +Definition hsstate_simu dm f outframe (hst1 hst2: hsstate) ctx: Prop := forall st1 st2, hsstate_refines hst1 st1 -> - hsstate_refines hst2 st2 -> sstate_simu dm f st1 st2 ctx. + hsstate_refines hst2 st2 -> sstate_simu dm f outframe st1 st2 ctx. -Theorem hsstate_simu_spec_correct dm f ctx hst1 hst2: - hsstate_simu_spec dm f hst1 hst2 -> - hsstate_simu dm f hst1 hst2 ctx. +Theorem hsstate_simu_spec_correct dm f outframe ctx hst1 hst2: + hsstate_simu_spec dm f outframe hst1 hst2 -> + hsstate_simu dm f outframe hst1 hst2 ctx. Proof. intros (SCORE & FSIMU) st1 st2 (SREF1 & DREF1 & FREF1) (SREF2 & DREF2 & FREF2). generalize SCORE. intro SIMU; eapply hsistate_simu_spec_correct in SIMU; eauto. diff --git a/scheduling/RTLpathSE_theory.v b/scheduling/RTLpathSE_theory.v index 4c492ecd..aa8db342 100644 --- a/scheduling/RTLpathSE_theory.v +++ b/scheduling/RTLpathSE_theory.v @@ -345,31 +345,13 @@ Qed. Lemma ssem_local_exclude_sabort_local ge sp loc rs m rs' m': ssem_local ge sp loc rs m rs' m' -> -(* all_fallthrough ge sp (si_exits st) rs m -> *) sabort_local ge sp loc rs m -> False. Proof. - intros SIML (* ALLF *) ABORT. inv SIML. destruct H0 as (H0 & H0'). + intros SIML ABORT. inv SIML. destruct H0 as (H0 & H0'). inversion ABORT as [ABORT1 | [ABORT2 | ABORT3]]; [ | | inv ABORT3]; congruence. Qed. -(* TODO: remove this JUNK ? -Lemma ssem_local_exclude_sabort_exit ge sp st ext lx rs m rs' m': - ssem_local ge sp (si_local st) rs m rs' m' -> - all_fallthrough ge sp (si_exits st) rs m -> - is_tail (ext :: lx) (si_exits st) -> - sabort_exit ge sp ext rs m -> - False. -Proof. - intros SSEML ALLF TAIL ABORT. - inv ABORT. - - exploit ALLF; eauto. congruence. - - (* FIXME Problem : if we have a ssem_local, this means we ONLY evaluated the conditions, - but we NEVER actually evaluated the si_elocal from the sistate_exit ! So we cannot prove - a lack of abort on the si_elocal.. We must change the definitions *) -Abort. -*) - Lemma ssem_local_exclude_sabort ge sp st rs m rs' m': ssem_local ge sp (si_local st) rs m rs' m' -> all_fallthrough ge sp (si_exits st) rs m -> @@ -497,7 +479,7 @@ Definition siexec_inst (i: instruction) (st: sistate): option sistate := let vargs := list_sval_inj (List.map prev.(si_sreg) args) in let ex := {| si_cond:=cond; si_scondargs:=vargs; si_elocal := prev; si_ifso := ifso |} in Some {| si_pc := ifnot; si_exits := ex::st.(si_exits); si_local := prev |} - | _ => None (* TODO jumptable ? *) + | _ => None end. Lemma seval_list_sval_inj ge sp l rs0 m0 (sreg: reg -> sval) rs: @@ -1627,13 +1609,9 @@ Definition istate_simulive alive (srce: PTree.t node) (is1 is2: istate): Prop := /\ eqlive_reg alive is1.(irs) is2.(irs) /\ is1.(imem) = is2.(imem). -Definition istate_simu f (srce: PTree.t node) is1 is2: Prop := +Definition istate_simu f (srce: PTree.t node) outframe is1 is2: Prop := if is1.(icontinue) then - (* TODO: il faudra raffiner le (fun _ => True) si on veut autoriser l'oracle à - ajouter du "code mort" sur des registres non utilisés (loop invariant code motion à la David) - Typiquement, pour connaître la frame des registres vivants, il faudra faire une propagation en arrière - sur la dernière instruction du superblock. *) - istate_simulive (fun _ => True) srce is1 is2 + istate_simulive (fun r => Regset.In r outframe) srce is1 is2 else exists path, f.(fn_path)!(is1.(ipc)) = Some path /\ istate_simulive (fun r => Regset.In r path.(input_regs)) srce is1 is2 @@ -1651,10 +1629,10 @@ Record simu_proof_context {f1: RTLpath.function} := { Arguments simu_proof_context: clear implicits. (* NOTE: a pure semantic definition on [sistate], for a total freedom in refinements *) -Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) (st1 st2: sistate) (ctx: simu_proof_context f): Prop := +Definition sistate_simu (dm: PTree.t node) (f: RTLpath.function) outframe (st1 st2: sistate) (ctx: simu_proof_context f): Prop := forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) st1 (the_rs0 ctx) (the_m0 ctx) is1 -> exists is2, ssem_internal (the_ge2 ctx) (the_sp ctx) st2 (the_rs0 ctx) (the_m0 ctx) is2 - /\ istate_simu f dm is1 is2. + /\ istate_simu f dm outframe is1 is2. Inductive svident_simu (f: RTLpath.function) (ctx: simu_proof_context f): (sval + ident) -> (sval + ident) -> Prop := | Sleft_simu sv1 sv2: @@ -1885,13 +1863,14 @@ Inductive sfval_simu (dm: PTree.t node) (f: RTLpath.function) (opc1 opc2: node) = (seval_sval (the_ge2 ctx) (the_sp ctx) sv2 (the_rs0 ctx) (the_m0 ctx)) -> sfval_simu dm f opc1 opc2 ctx (Sreturn (Some sv1)) (Sreturn (Some sv2)). -Definition sstate_simu dm f (s1 s2: sstate) (ctx: simu_proof_context f): Prop := - sistate_simu dm f s1.(internal) s2.(internal) ctx - /\ forall is1, +Definition sstate_simu dm f outframe (s1 s2: sstate) (ctx: simu_proof_context f): Prop := + sistate_simu dm f outframe s1.(internal) s2.(internal) ctx + /\ forall is1, ssem_internal (the_ge1 ctx) (the_sp ctx) s1 (the_rs0 ctx) (the_m0 ctx) is1 -> is1.(icontinue) = true -> sfval_simu dm f s1.(si_pc) s2.(si_pc) ctx s1.(final) s2.(final). Definition sexec_simu dm (f1 f2: RTLpath.function) pc1 pc2: Prop := forall st1, sexec f1 pc1 = Some st1 -> - exists st2, sexec f2 pc2 = Some st2 /\ forall ctx, sstate_simu dm f1 st1 st2 ctx. + exists path st2, (fn_path f1)!pc1 = Some path /\ sexec f2 pc2 = Some st2 + /\ forall ctx, sstate_simu dm f1 path.(pre_output_regs) st1 st2 ctx. diff --git a/scheduling/RTLpathScheduler.v b/scheduling/RTLpathScheduler.v index beab405f..1baf3fca 100644 --- a/scheduling/RTLpathScheduler.v +++ b/scheduling/RTLpathScheduler.v @@ -7,7 +7,7 @@ This module is inspired from [Duplicate] and [Duplicateproof] Require Import AST Linking Values Maps Globalenvs Smallstep Registers. Require Import Coqlib Maps Events Errors Op. Require Import RTL RTLpath RTLpathLivegen RTLpathLivegenproof RTLpathSE_theory RTLpathSE_impl. - +Require RTLpathWFcheck. Notation "'ASSERT' A 'WITH' MSG 'IN' B" := (if A then B else Error (msg MSG)) (at level 200, A at level 100, B at level 200) @@ -32,14 +32,14 @@ Extract Constant untrusted_scheduler => "RTLpathScheduleraux.scheduler". Program Definition function_builder (tfr: RTL.function) (tpm: path_map) : { r : res RTLpath.function | forall f', r = OK f' -> fn_RTL f' = tfr} := - match RTLpathLivegen.function_checker tfr tpm with + match RTLpathWFcheck.function_checker tfr tpm with | false => Error (msg "In function_builder: (tfr, tpm) is not wellformed") | true => OK {| fn_RTL := tfr; fn_path := tpm |} end. Next Obligation. - apply function_checker_path_entry. auto. + apply RTLpathWFcheck.function_checker_path_entry. auto. Defined. Next Obligation. - apply function_checker_wellformed_path_map. auto. + apply RTLpathWFcheck.function_checker_wellformed_path_map. auto. Defined. Definition entrypoint_check (dm: PTree.t node) (fr tfr: RTL.function) : res unit := @@ -158,7 +158,7 @@ Definition verified_scheduler (f: RTLpath.function) : res (RTLpath.function * (P let (tc, te) := tcte in let tfr := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in do tf <- proj1_sig (function_builder tfr tpm); - do tt <- function_equiv_checker dm f tf; + do tt <- function_equiv_checker dm f tf; OK (tf, dm). Theorem verified_scheduler_correct f tf dm: @@ -179,8 +179,8 @@ Proof. destruct (function_builder _ _) as [res H]; simpl in * |- *; auto. apply H in EQ2. rewrite EQ2. simpl. repeat (constructor; eauto). - - exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. -Qed. + exploit function_equiv_checker_entrypoint. eapply EQ4. rewrite EQ2. intuition. +Qed. Record match_function (dupmap: PTree.t node) (f1 f2: RTLpath.function): Prop := { preserv_fnsig: fn_sig f1 = fn_sig f2; @@ -327,4 +327,3 @@ Proof. eapply match_Internal; eauto. + eapply match_External. Qed. - diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml index a294d0b5..b13d559e 100644 --- a/scheduling/RTLpathScheduleraux.ml +++ b/scheduling/RTLpathScheduleraux.ml @@ -1,28 +1,19 @@ +open DebugPrint +open Machine +open RTLpathLivegenaux open RTLpath +open RTLpathCommon open RTL open Maps -open RTLpathLivegenaux open Registers -open Camlcoq -open Machine -open DebugPrint +open ExpansionOracle let config = Machine.config -type superblock = { - instructions: P.t array; (* pointers to code instructions *) - (* each predicted Pcb has its attached liveins *) - (* This is indexed by the pc value *) - liveins: Regset.t PTree.t; - (* Union of the input_regs of the last successors *) - output_regs: Regset.t; - typing: RTLtyping.regenv -} - let print_superblock sb code = let insts = sb.instructions in let li = sb.liveins in - let outs = sb.output_regs in + let outs = sb.s_output_regs in begin debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n"; debug " liveins = "; print_ptree_regset li; debug "\n"; @@ -71,7 +62,7 @@ let get_superblocks code entry pm typing = let pi = get_some @@ PTree.get pc pm in let (insts, nexts) = follow pc (Camlcoq.Nat.to_int pi.psize) in let superblock = { instructions = Array.of_list insts; liveins = !liveins; - output_regs = pi.output_regs; typing = typing } in + s_output_regs = pi.output_regs; typing = typing } in superblock :: (List.concat @@ List.map get_superblocks_rec nexts) end in let lsb = get_superblocks_rec entry in begin @@ -289,25 +280,31 @@ let turn_all_loads_nontrap sb code = !code' end -let rec do_schedule code = function - | [] -> code +let rec do_schedule code pm = function + | [] -> (code, pm) | sb :: lsb -> + (*debug_flag := true;*) + let (code_exp, pm) = + if !Clflags.option_fexpanse_rtlcond then (expanse sb code pm) + else (code, pm) in + (*debug_flag := false;*) (* Trick: instead of turning loads into non trap as needed.. * First, we turn them all into non-trap. * Then, we turn back those who didn't need to be turned, into TRAP again * This is because the scheduler (rightfully) refuses to schedule ahead of a branch * operations that might trap *) - let code' = turn_all_loads_nontrap sb code in + let code' = turn_all_loads_nontrap sb code_exp in let schedule = schedule_superblock sb code' in let new_code = apply_schedule code' sb schedule in begin - (* debug_flag := true; *) + (*debug_flag := true;*) debug "Old Code: "; print_code code; + debug "Exp Code: "; print_code code_exp; debug "\nSchedule to apply: "; print_arrayp schedule; debug "\nNew Code: "; print_code new_code; debug "\n"; - (* debug_flag := false; *) - do_schedule new_code lsb + (*debug_flag := false; *) + do_schedule new_code pm lsb end let get_ok r = match r with Errors.OK x -> x | _ -> failwith "Did not get OK" @@ -324,8 +321,11 @@ let scheduler f = debug "Pathmap:\n"; debug "\n"; print_path_map pm; debug "Superblocks:\n"; - print_superblocks lsb code; debug "\n"; - (* debug_flag := false; *) - let tc = do_schedule code lsb in + (*debug_flag := true; *) + (*print_code code; flush stdout; flush stderr;*) + (*debug_flag := false;*) + (*print_superblocks lsb code; debug "\n";*) + find_last_node_reg (PTree.elements code); + let (tc, pm) = do_schedule code pm lsb in (((tc, entry), pm), id_ptree) end diff --git a/scheduling/RTLpathSchedulerproof.v b/scheduling/RTLpathSchedulerproof.v index 4ba197b0..a9c2fa76 100644 --- a/scheduling/RTLpathSchedulerproof.v +++ b/scheduling/RTLpathSchedulerproof.v @@ -143,13 +143,25 @@ Obligation 2. erewrite symbols_preserved_RTL. eauto. Qed. +Lemma s_find_function_fundef f sp svos rs0 m0 fd + (LIVE: liveness_ok_function f): + sfind_function pge ge sp svos rs0 m0 = Some fd -> + liveness_ok_fundef fd. +Proof. + unfold sfind_function. destruct svos; simpl. + + destruct (seval_sval _ _ _ _); try congruence. + eapply find_funct_liveness_ok; eauto. + + destruct (Genv.find_symbol _ _); try congruence. + intros. eapply all_fundef_liveness_ok; eauto. +Qed. +Local Hint Resolve s_find_function_fundef: core. + Lemma s_find_function_preserved f sp svos1 svos2 rs0 m0 fd (LIVE: liveness_ok_function f): (svident_simu f (mkctx sp rs0 m0 LIVE) svos1 svos2) -> sfind_function pge ge sp svos1 rs0 m0 = Some fd -> exists fd', sfind_function tpge tge sp svos2 rs0 m0 = Some fd' - /\ transf_fundef fd = OK fd' - /\ liveness_ok_fundef fd. + /\ transf_fundef fd = OK fd'. Proof. Local Hint Resolve symbols_preserved_RTL: core. unfold sfind_function. intros [sv1 sv2 SIMU|]; simpl in *. @@ -159,20 +171,16 @@ Proof. intros; exploit functions_preserved; eauto. intros (fd' & cunit & (X1 & X2 & X3)). eexists. repeat split; eauto. - eapply find_funct_liveness_ok; eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) + subst. rewrite symbols_preserved. destruct (Genv.find_symbol _ _); try congruence. intros; exploit function_ptr_preserved; eauto. - intros (fd' & X). eexists. intuition eauto. -(* intros. eapply all_fundef_liveness_ok; eauto. *) Qed. -Lemma sistate_simu f dupmap sp st st' rs m is +Lemma sistate_simu f dupmap outframe sp st st' rs m is (LIVE: liveness_ok_function f): ssem_internal ge sp st rs m is -> - sistate_simu dupmap f st st' (mkctx sp rs m LIVE)-> + sistate_simu dupmap f outframe st st' (mkctx sp rs m LIVE)-> exists is', - ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap is is'. + ssem_internal tge sp st' rs m is' /\ istate_simu f dupmap outframe is is'. Proof. intros SEM X; eapply X; eauto. Qed. @@ -198,13 +206,12 @@ Lemma ssem_final_simu dm f f' stk stk' sp st st' rs0 m0 sv sv' rs m t s (LIVE: liveness_ok_function f): match_function dm f f' -> list_forall2 match_stackframes stk stk' -> - (* s_istate_simu f dupmap st st' -> *) sfval_simu dm f st.(si_pc) st'.(si_pc) (mkctx sp rs0 m0 LIVE) sv sv' -> ssem_final pge ge sp st.(si_pc) stk f rs0 m0 sv rs m t s -> exists s', ssem_final tpge tge sp st'.(si_pc) stk' f' rs0 m0 sv' rs m t s' /\ match_states s s'. Proof. Local Hint Resolve transf_fundef_correct: core. - intros FUN STK (* SIS *) SFV. destruct SFV; intros SEM; inv SEM; simpl in *. + intros FUN STK SFV. destruct SFV; intros SEM; inv SEM; simpl in *. - (* Snone *) exploit initialize_path. { eapply dupmap_path_entry1; eauto. } intros (path & PATH). @@ -212,7 +219,7 @@ Proof. eapply eqlive_reg_refl. - (* Scall *) exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). + intros (fd' & FIND & TRANSF). erewrite <- function_sig_preserved; eauto. exploit initialize_path. { eapply dupmap_path_entry1; eauto. } intros (path & PATH). @@ -221,7 +228,7 @@ Proof. + simpl. repeat (econstructor; eauto). - (* Stailcall *) exploit s_find_function_preserved; eauto. - intros (fd' & FIND & TRANSF & LIVE'). + intros (fd' & FIND & TRANSF). erewrite <- function_sig_preserved; eauto. eexists; split; econstructor; eauto. + erewrite <- preserv_fnstacksize; eauto. @@ -253,18 +260,154 @@ Proof. + rewrite <- H. erewrite <- seval_preserved; eauto. Qed. +Lemma siexec_snone_por_correct rs' is t s alive path0 i sp s0 st0 stk stk' f rs0 m0: forall + (SSEM2 : ssem_final pge ge sp (si_pc s0) stk f rs0 m0 Snone + (irs is) (imem is) t s) + (SIEXEC : siexec_inst i st0 = Some s0) + (ICHK : inst_checker (fn_path f) alive (pre_output_regs path0) i = Some tt), + (liveness_ok_function f) -> + list_forall2 match_stackframes stk stk' -> + eqlive_reg (fun r : Regset.elt => Regset.In r (pre_output_regs path0)) (irs is) rs' -> + exists s' : state, + ssem_final pge ge sp (si_pc s0) stk f rs0 m0 Snone rs' (imem is) t s' /\ + eqlive_states s s'. +Proof. + Local Hint Resolve eqlive_stacks_refl: core. + intros ? ? ? LIVE STK EQLIVE. + inversion SSEM2; subst; clear SSEM2. + eexists; split. + * econstructor. + * generalize ICHK. + unfold inst_checker. destruct i; simpl in *; + unfold exit_checker; try discriminate. + all: + try destruct (list_mem _ _); simpl; + try (destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence; fail). + 4,5: + destruct (Regset.mem _ _); destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + 1,2,3,4: assert (NPC: n=(si_pc s0)). + all: try (inv SIEXEC; simpl; auto; fail). + 1,2,3,4: + try (destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence); + simpl; inversion_SOME p; + destruct (Regset.subset (input_regs p) (pre_output_regs path0)) eqn:SUB_PATH; try congruence; + intros NPATH _; econstructor; eauto; + try (instantiate (1:=p); rewrite <- NPC; auto; fail). + 1,2,3,4: + eapply eqlive_reg_monotonic; eauto; simpl; + intros; apply Regset.subset_2 in SUB_PATH; + unfold Regset.Subset in SUB_PATH; + apply SUB_PATH in H; auto. + assert (NPC: n0=(si_pc s0)). { inv SIEXEC; simpl; auto. } + inversion_SOME p. + 2: { destruct (Regset.subset _ _) eqn:?; try congruence. } + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + 2: { destruct (Regset.subset (pre_output_regs path0) alive) eqn:?; try congruence. } + simpl. + destruct (Regset.subset (pre_output_regs path0) alive) eqn:SUB_ALIVE'; try congruence. + inversion_SOME p'. + destruct (Regset.subset (input_regs p') (pre_output_regs path0)) eqn:SUB_PATH; try congruence. + intros NPATH NPATH' _. econstructor; eauto. + instantiate (1:=p'). rewrite <- NPC; auto. + eapply eqlive_reg_monotonic; eauto; simpl. + intros. apply Regset.subset_2 in SUB_PATH. + unfold Regset.Subset in SUB_PATH. + apply SUB_PATH in H; auto. +Qed. + +Lemma pre_output_regs_correct f pc0 path0 stk stk' sp (st:sstate) rs0 m0 t s is rs': + (liveness_ok_function f) -> + (fn_path f) ! pc0 = Some path0 -> + sexec f pc0 = Some st -> + list_forall2 match_stackframes stk stk' -> + ssem_final pge ge sp (si_pc st) stk f rs0 m0 (final st) (irs is) (imem is) t s -> + eqlive_reg (fun r : Regset.elt => Regset.In r (pre_output_regs path0)) (irs is) rs' -> + exists s', ssem_final pge ge sp (si_pc st) stk f rs0 m0 (final st) rs' (imem is) t s' /\ eqlive_states s s'. +Proof. + Local Hint Resolve eqlive_stacks_refl: core. + intros LIVE PATH0 SEXEC STK SSEM2 EQLIVE. + (* start decomposing path_checker *) + generalize (LIVE pc0 path0 PATH0). + unfold path_checker. + inversion_SOME res; intros IPCHK. + inversion_SOME i; intros INST ICHK. + exploit ipath_checker_default_succ; eauto. intros DEFSUCC. + (* start decomposing SEXEC *) + generalize SEXEC; clear SEXEC. + unfold sexec; rewrite PATH0. + inversion_SOME st0; intros SEXEC_PATH. + exploit siexec_path_default_succ; eauto. + simpl. rewrite DEFSUCC. + clear DEFSUCC. destruct res as [alive pc1]. simpl in *. + try_simplify_someHyps. + destruct (siexec_inst i st0) eqn: SIEXEC; try_simplify_someHyps; intros. + (* Snone *) + eapply siexec_snone_por_correct; eauto. + destruct i; try_simplify_someHyps; try congruence; + inversion SSEM2; subst; clear SSEM2; simpl in *. + + (* Scall *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. + econstructor; eauto. + (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (list_mem _ _); try congruence. + destruct (reg_sum_mem _ _); try congruence. + intros EXIT. + exploit exit_checker_eqlive_ext1; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Stailcall *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. + + (* Sbuiltin *) + eexists; split. + * econstructor; eauto. + * (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (list_mem _ _); try congruence. + intros EXIT. + exploit exit_checker_eqlive_builtin_res; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Sjumptable *) + eexists; split. + * econstructor; eauto. + * (* wf *) + generalize ICHK. + unfold inst_checker; simpl in *. + destruct (Regset.subset _ _) eqn:SUB_ALIVE; try congruence. + destruct (Regset.mem _ _); try congruence. + destruct (exit_list_checker _ _ _) eqn:EQL; try congruence. + exploit exit_list_checker_eqlive; eauto. + intros. destruct H as [p [PATH EQLIVE']]. + econstructor; eauto. + + (* Sreturn *) + eexists; split. + * econstructor; eauto. + * econstructor; eauto. +Qed. + (* The main theorem on simulation of symbolic states ! *) -Theorem ssem_sstate_simu dm f f' stk stk' sp st st' rs m t s: +Theorem ssem_sstate_simu dm f f' pc0 path0 stk stk' sp st st' rs m t s: + (fn_path f) ! pc0 = Some path0 -> + sexec f pc0 = Some st -> match_function dm f f' -> liveness_ok_function f -> list_forall2 match_stackframes stk stk' -> ssem pge ge sp st stk f rs m t s -> - (forall ctx: simu_proof_context f, sstate_simu dm f st st' ctx) -> + (forall ctx: simu_proof_context f, sstate_simu dm f (pre_output_regs path0) st st' ctx) -> exists s', ssem tpge tge sp st' stk' f' rs m t s' /\ match_states s s'. Proof. - intros MFUNC LIVE STACKS SEM SIMU. + intros PATH0 SEXEC MFUNC LIVE STACKS SEM SIMU. destruct (SIMU (mkctx sp rs m LIVE)) as (SIMU1 & SIMU2); clear SIMU. - destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl. + destruct SEM as [is CONT SEM|is t s' CONT SEM1 SEM2]; simpl in *. - (* sem_early *) exploit sistate_simu; eauto. unfold istate_simu; rewrite CONT. @@ -276,15 +419,17 @@ Proof. - (* sem_normal *) exploit sistate_simu; eauto. unfold istate_simu; rewrite CONT. - intros (is' & SEM' & (CONT' & RS' & M')(* & DMEQ *)). - rewrite <- eqlive_reg_triv in RS'. + intros (is' & SEM' & (CONT' & RS' & M')). + exploit pre_output_regs_correct; eauto. + clear SEM2; intros (s0 & SEM2 & EQLIVE). exploit ssem_final_simu; eauto. - clear SEM2; intros (s0 & SEM2 & MATCH0). + clear SEM2; intros (s1 & SEM2 & MATCH0). exploit ssem_final_equiv; eauto. - clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s1 & EQ & SEM2). - exists s1; split. + clear SEM2; rewrite M'; rewrite CONT' in CONT; intros (s2 & EQ & SEM2). + exists s2; split. + eapply ssem_normal; eauto. - + eapply match_states_equiv; eauto. + + eapply eqlive_match_states; eauto. + eapply match_states_equiv; eauto. Qed. Lemma exec_path_simulation dupmap path stk stk' f f' sp rs m pc pc' t s: @@ -301,12 +446,13 @@ Proof. intros (path' & PATH'). exists path'. exploit (sexec_correct f pc pge ge sp path stk rs m t s); eauto. - intros (st & SYMB & SEM); clear STEP. + intros (st & SYMB & SEM). exploit dupmap_correct; eauto. - clear SYMB; intros (st' & SYMB & SIMU). + intros (path0 & st' & PATH0 & SYMB' & SIMU). + rewrite PATH0 in PATH; inversion PATH; subst. exploit ssem_sstate_simu; eauto. intros (s0 & SEM0 & MATCH). - exploit sexec_exact; eauto. + exploit (sexec_exact f'); eauto. intros (s' & STEP' & EQ). exists s'; intuition. eapply match_states_equiv; eauto. diff --git a/scheduling/RTLpathWFcheck.v b/scheduling/RTLpathWFcheck.v new file mode 100644 index 00000000..63b914ec --- /dev/null +++ b/scheduling/RTLpathWFcheck.v @@ -0,0 +1,187 @@ +Require Import Coqlib. +Require Import Maps. +Require Import Lattice. +Require Import AST. +Require Import Op. +Require Import Registers. +Require Import Globalenvs Smallstep RTL RTLpath. +Require Import Bool Errors. +Require Import Program. +Require RTLpathLivegen. + +Local Open Scope lazy_bool_scope. + +Local Open Scope option_monad_scope. + +Definition exit_checker {A} (pm: path_map) (pc: node) (v:A): option A := + SOME path <- pm!pc IN + Some v. + +Lemma exit_checker_path_entry A (pm: path_map) (pc: node) (v:A) res: + exit_checker pm pc v = Some res -> path_entry pm pc. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; simpl; congruence. +Qed. + +Lemma exit_checker_res A (pm: path_map) (pc: node) (v:A) res: + exit_checker pm pc v = Some res -> v=res. +Proof. + unfold exit_checker, path_entry. + inversion_SOME path; try_simplify_someHyps. +Qed. + +Definition iinst_checker (pm: path_map) (i: instruction): option (node) := + match i with + | Inop pc' | Iop _ _ _ pc' | Iload _ _ _ _ _ pc' + | Istore _ _ _ _ pc' => Some (pc') + | Icond cond args ifso ifnot _ => + exit_checker pm ifso ifnot + | _ => None + end. + +Local Hint Resolve exit_checker_path_entry: core. + +Lemma iinst_checker_path_entry (pm: path_map) (i: instruction) res pc: + iinst_checker pm i = Some res -> + early_exit i = Some pc -> path_entry pm pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst. +Qed. + +Lemma iinst_checker_default_succ (pm: path_map) (i: instruction) res pc: + iinst_checker pm i = Some res -> + pc = res -> + default_succ i = Some pc. +Proof. + destruct i; simpl; try_simplify_someHyps; subst; + repeat (inversion_ASSERT); try_simplify_someHyps. + intros; exploit exit_checker_res; eauto. + intros; subst. simpl; auto. +Qed. + +Fixpoint ipath_checker (ps:nat) (f: RTL.function) (pm: path_map) (pc:node): option (node) := + match ps with + | O => Some (pc) + | S p => + SOME i <- f.(fn_code)!pc IN + SOME res <- iinst_checker pm i IN + ipath_checker p f pm res + end. + +Lemma ipath_checker_wellformed f pm ps: forall pc res, + ipath_checker ps f pm pc = Some res -> + wellformed_path f.(fn_code) pm 0 res -> + wellformed_path f.(fn_code) pm ps pc. +Proof. + induction ps; simpl; try_simplify_someHyps. + inversion_SOME i; inversion_SOME res'. + intros. eapply wf_internal_node; eauto. + * eapply iinst_checker_default_succ; eauto. + * intros; eapply iinst_checker_path_entry; eauto. +Qed. + +Fixpoint exit_list_checker (pm: path_map) (l: list node): bool := + match l with + | nil => true + | pc::l' => exit_checker pm pc tt &&& exit_list_checker pm l' + end. + +Lemma exit_list_checker_correct pm l pc: + exit_list_checker pm l = true -> List.In pc l -> exit_checker pm pc tt = Some tt. +Proof. + intros EXIT PC; induction l; intuition. + simpl in * |-. rewrite RTLpathLivegen.lazy_and_Some_tt_true in EXIT. + firstorder (subst; eauto). +Qed. + +Local Hint Resolve exit_list_checker_correct: core. + +Definition inst_checker (pm: path_map) (i: instruction): option unit := + match i with + | Icall sig ros args res pc' => + exit_checker pm pc' tt + | Itailcall sig ros args => + Some tt + | Ibuiltin ef args res pc' => + exit_checker pm pc' tt + | Ijumptable arg tbl => + ASSERT exit_list_checker pm tbl IN + Some tt + | Ireturn optarg => + Some tt + | _ => + SOME res <- iinst_checker pm i IN + exit_checker pm res tt + end. + +Lemma inst_checker_wellformed (c:code) pc (pm: path_map) (i: instruction): + inst_checker pm i = Some tt -> + c!pc = Some i -> wellformed_path c pm 0 pc. +Proof. + intros CHECK PC. eapply wf_last_node; eauto. + clear c pc PC. intros pc PC. + destruct i; simpl in * |- *; intuition (subst; eauto); + try (generalize CHECK; clear CHECK; try (inversion_SOME path); repeat inversion_ASSERT; try_simplify_someHyps). + intros X; exploit exit_checker_res; eauto. + clear X. intros; subst; eauto. +Qed. + +Definition path_checker (f: RTL.function) pm (pc: node) (path:path_info): option unit := + SOME res <- ipath_checker (path.(psize)) f pm pc IN + SOME i <- f.(fn_code)!res IN + inst_checker pm i. + +Lemma path_checker_wellformed f pm pc path: + path_checker f pm pc path = Some tt -> wellformed_path (f.(fn_code)) pm (path.(psize)) pc. +Proof. + unfold path_checker. + inversion_SOME res. + inversion_SOME i. + intros; eapply ipath_checker_wellformed; eauto. + eapply inst_checker_wellformed; eauto. +Qed. + +Fixpoint list_path_checker f pm (l:list (node*path_info)): bool := + match l with + | nil => true + | (pc, path)::l' => + path_checker f pm pc path &&& list_path_checker f pm l' + end. + +Lemma list_path_checker_correct f pm l: + list_path_checker f pm l = true -> forall e, List.In e l -> path_checker f pm (fst e) (snd e) = Some tt. +Proof. + intros CHECKER e H; induction l as [|(pc & path) l]; intuition. + simpl in * |- *. rewrite RTLpathLivegen.lazy_and_Some_tt_true in CHECKER. intuition (subst; auto). +Qed. + +Definition function_checker (f: RTL.function) (pm: path_map): bool := + pm!(f.(fn_entrypoint)) &&& list_path_checker f pm (PTree.elements pm). + +Lemma function_checker_correct f pm pc path: + function_checker f pm = true -> + pm!pc = Some path -> + path_checker f pm pc path = Some tt. +Proof. + unfold function_checker; rewrite RTLpathLivegen.lazy_and_Some_true. + intros (ENTRY & PATH) PC. + exploit list_path_checker_correct; eauto. + - eapply PTree.elements_correct; eauto. + - simpl; auto. +Qed. + +Lemma function_checker_wellformed_path_map f pm: + function_checker f pm = true -> wellformed_path_map f.(fn_code) pm. +Proof. + unfold wellformed_path_map. + intros; eapply path_checker_wellformed; eauto. + intros; eapply function_checker_correct; eauto. +Qed. + +Lemma function_checker_path_entry f pm: + function_checker f pm = true -> path_entry pm (f.(fn_entrypoint)). +Proof. + unfold function_checker; rewrite RTLpathLivegen.lazy_and_Some_true; + unfold path_entry. firstorder congruence. +Qed. diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 8d4f4f0b..ddb3c21a 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -32,6 +32,7 @@ PARTIAL, Always, NoRequire, (Some "Unrolling the body of innermost loops"), "Unr TOTAL, Always, NoRequire, (Some "Renumbering pre constprop"), "Renumber"; TOTAL, (Option "optim_constprop"), Require, (Some "Constant propagation"), "Constprop"; TOTAL, Always, NoRequire, (Some "Renumbering pre CSE"), "Renumber"; +PARTIAL, (Option "optim_CSE"), Require, (Some "CSE"), "CSE"; TOTAL, (Option "optim_CSE2"), Require, (Some "CSE2"), "CSE2"; PARTIAL, (Option "optim_CSE3"), Require, (Some "CSE3"), "CSE3"; TOTAL, (Option "optim_CSE3"), Require, (Some "Kill useless moves after CSE3"), "KillUselessMoves"; |