From ca92d5ab93f2ee63ff416a096fdbfa569a64c717 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:27:06 +0200 Subject: sdiv seems to work, udiv/umod/smod BOGUS --- mppa_k1c/SelectOp.vp | 12 ++-------- mppa_k1c/SelectOpproof.v | 18 ++++++++++++-- runtime/mppa_k1c/i64_sdiv.c | 10 -------- runtime/mppa_k1c/i64_smod.c | 40 ------------------------------- runtime/mppa_k1c/vararg.S | 51 ++++++++++++++++++++++++++++++++++++++++ test/monniaux/division/sum_div.c | 18 -------------- 6 files changed, 69 insertions(+), 80 deletions(-) delete mode 100644 test/monniaux/division/sum_div.c diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index aac3010e..6adcebe5 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -423,18 +423,10 @@ Definition mods_base (e1: expr) (e2: expr) := Eexternal i32_smod sig_ii_i (e1 ::: e2 ::: Enil). Definition divu_base (e1: expr) (e2: expr) := - Eop Olowlong - ((Eexternal i64_udiv sig_ll_l - ((Eop Ocast32unsigned (e1 ::: Enil))::: - (Eop Ocast32unsigned (e2 ::: Enil))::: Enil)) - :::Enil). + Eexternal i32_udiv sig_ii_i (e1 ::: e2 ::: Enil). Definition modu_base (e1: expr) (e2: expr) := - Eop Olowlong - ((Eexternal i64_umod sig_ll_l - ((Eop Ocast32unsigned (e1 ::: Enil))::: - (Eop Ocast32unsigned (e2 ::: Enil))::: Enil)) - :::Enil). + Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). Definition shrximm (e1: expr) (n2: int) := if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index d22725d5..22eecfad 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -872,6 +872,12 @@ Theorem eval_divu_base: Val.divu x y = Some z -> exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. Proof. + intros; unfold divu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +(* For using 64-bit unsigned division for 32-bit + intros until z. intros Hax Hby Hdiv. unfold divu_base. pose proof (divu_is_divlu x y) as DIVU. @@ -891,7 +897,8 @@ Proof. } congruence. Qed. - + *) + Theorem eval_modu_base: forall le a b x y z, eval_expr ge sp e m le a x -> @@ -899,6 +906,12 @@ Theorem eval_modu_base: Val.modu x y = Some z -> exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. Proof. + intros; unfold modu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +(* for using 64-bit unsigned modulo for 32-bit + intros until z. intros Hax Hby Hmod. unfold modu_base. pose proof (modu_is_modlu x y) as MODU. @@ -918,7 +931,8 @@ Proof. } congruence. Qed. - + *) + Theorem eval_shrximm: forall le a n x z, eval_expr ge sp e m le a x -> diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c index 9feab791..809f2b1c 100644 --- a/runtime/mppa_k1c/i64_sdiv.c +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -1,15 +1,5 @@ extern long __divdi3 (long a, long b); -long i64_sdiv (long a, long b) -{ - return __divdi3 (a, b); -} - -int i32_sdiv (int a, int b) -{ - return __divdi3 (a, b); -} - #include /* DM FIXME this is for floating point */ diff --git a/runtime/mppa_k1c/i64_smod.c b/runtime/mppa_k1c/i64_smod.c index 26ffb39b..e69de29b 100644 --- a/runtime/mppa_k1c/i64_smod.c +++ b/runtime/mppa_k1c/i64_smod.c @@ -1,40 +0,0 @@ -#if COMPLIQUE -unsigned long long -udivmoddi4(unsigned long long num, unsigned long long den, int modwanted); - -long long -i64_smod (long long a, long long b) -{ - int neg = 0; - long long res; - - if (a < 0) - { - a = -a; - neg = 1; - } - - if (b < 0) - b = -b; - - res = udivmoddi4 (a, b, 1); - - if (neg) - res = -res; - - return res; -} - -#else -extern long __moddi3 (long a, long b); - -long i64_smod (long a, long b) -{ - return __moddi3 (a, b); -} - -int i32_smod (int a, int b) -{ - return __moddi3 (a, b); -} -#endif diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index 9e23e0b3..2050c9aa 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -52,3 +52,54 @@ __compcert_acswapw: sq 0[$r0] = $r2r3 ret ;; + + .globl __compcert_i32_sdiv + .globl __compcert_i32_smod + .globl __compcert_i32_udiv + .globl __compcert_i32_umod +__compcert_i32_sdiv: +__compcert_i32_smod: +__compcert_i32_udiv: +__compcert_i32_umod: + sxwd $r0 = $r0 + ;; /* Can't issue next in the same bundle */ + sxwd $r1 = $r1 + ;; /* Can't issue next in the same bundle */ + make $r2 = 0x3ff0000000000000 + addd $r12 = $r12, -16 + ;; + floatd.rn.s $r0 = $r0, 0 + ;; + floatd.rn.s $r3 = $r1, 0 + ;; + floatw.rn.s $r1 = $r1, 0 + ;; + ;; +#APP +# 16 "clock_int_div2.c" 1 + finvw $r1=$r1 +# 0 "" 2 + ;; + + ;; +#NO_APP + fwidenlwd $r1 = $r1 + ;; + fmuld $r0 = $r0, $r1 + ;; + ffmsd $r2 = $r1, $r3 + ;; + sd 8[$r12] = $r0 + ;; + ld $r1 = 8[$r12] + ;; + ffmad $r1 = $r2, $r0 + ;; + ffmad $r0 = $r2, $r1 + ;; + sd 8[$r12] = $r1 + addd $r12 = $r12, 16 + ;; + fixedd.rz $r0 = $r0, 0 + ret + ;; diff --git a/test/monniaux/division/sum_div.c b/test/monniaux/division/sum_div.c deleted file mode 100644 index 87256922..00000000 --- a/test/monniaux/division/sum_div.c +++ /dev/null @@ -1,18 +0,0 @@ -#include -#include -#include "../clock.h" - -int main(int argc, char **argv) { - unsigned modulus = argc < 2 ? 3371 : atoi(argv[1]); - clock_prepare(); - clock_start(); - unsigned total=0, total_mod=0; - for(int i=0; i<1000; i++) { - total += i; - total_mod = (total_mod + i)%modulus; - } - clock_stop(); - print_total_clock(); - printf("%u %u %d\n", total, total_mod, total%modulus == total_mod); - return 0; -} -- cgit From acc7b444ba2ccdf7273bb0da128a6cdfe392dc5d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:29:15 +0200 Subject: simplify sdiv code --- runtime/mppa_k1c/vararg.S | 8 -------- 1 file changed, 8 deletions(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index 2050c9aa..e0b73811 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -62,7 +62,6 @@ __compcert_i32_smod: __compcert_i32_udiv: __compcert_i32_umod: sxwd $r0 = $r0 - ;; /* Can't issue next in the same bundle */ sxwd $r1 = $r1 ;; /* Can't issue next in the same bundle */ make $r2 = 0x3ff0000000000000 @@ -74,15 +73,8 @@ __compcert_i32_umod: ;; floatw.rn.s $r1 = $r1, 0 ;; - ;; -#APP -# 16 "clock_int_div2.c" 1 finvw $r1=$r1 -# 0 "" 2 - ;; - ;; -#NO_APP fwidenlwd $r1 = $r1 ;; fmuld $r0 = $r0, $r1 -- cgit From a36a8c77b67ad1e054cb7aabae53817e98c00088 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:31:17 +0200 Subject: simplify sdiv code --- runtime/mppa_k1c/vararg.S | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index e0b73811..d3626c25 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -80,10 +80,7 @@ __compcert_i32_umod: fmuld $r0 = $r0, $r1 ;; ffmsd $r2 = $r1, $r3 - ;; - sd 8[$r12] = $r0 - ;; - ld $r1 = 8[$r12] + copyd $r1 = $r0 ;; ffmad $r1 = $r2, $r0 ;; -- cgit From aecc44ba24c68b03f5cd978ce193ac9b7bc9bb42 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:32:51 +0200 Subject: simplify sdiv --- runtime/mppa_k1c/vararg.S | 5 ----- 1 file changed, 5 deletions(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index d3626c25..e7b05893 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -63,9 +63,7 @@ __compcert_i32_udiv: __compcert_i32_umod: sxwd $r0 = $r0 sxwd $r1 = $r1 - ;; /* Can't issue next in the same bundle */ make $r2 = 0x3ff0000000000000 - addd $r12 = $r12, -16 ;; floatd.rn.s $r0 = $r0, 0 ;; @@ -86,9 +84,6 @@ __compcert_i32_umod: ;; ffmad $r0 = $r2, $r1 ;; - sd 8[$r12] = $r1 - addd $r12 = $r12, 16 - ;; fixedd.rz $r0 = $r0, 0 ret ;; -- cgit From be0b9e66ce1fd71830d9316a13afc64d9a71552e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:47:28 +0200 Subject: udiv --- runtime/mppa_k1c/vararg.S | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index e7b05893..9869eb0b 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -59,7 +59,6 @@ __compcert_acswapw: .globl __compcert_i32_umod __compcert_i32_sdiv: __compcert_i32_smod: -__compcert_i32_udiv: __compcert_i32_umod: sxwd $r0 = $r0 sxwd $r1 = $r1 @@ -87,3 +86,31 @@ __compcert_i32_umod: fixedd.rz $r0 = $r0, 0 ret ;; + +__compcert_i32_udiv: + zxwd $r0 = $r0 + zxwd $r1 = $r1 + make $r2 = 0x3ff0000000000000 + ;; + floatud.rn.s $r0 = $r0, 0 + ;; + floatud.rn.s $r3 = $r1, 0 + ;; + floatuw.rn.s $r1 = $r1, 0 + ;; + finvw $r1=$r1 + ;; + fwidenlwd $r1 = $r1 + ;; + fmuld $r0 = $r0, $r1 + ;; + ffmsd $r2 = $r1, $r3 + copyd $r1 = $r0 + ;; + ffmad $r1 = $r2, $r0 + ;; + ffmad $r0 = $r2, $r1 + ;; + fixedud.rz $r0 = $r0, 0 + ret + ;; -- cgit From 7d59276032275776e1f37dfb99ad2f60bc6ab639 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:52:35 +0200 Subject: umod --- runtime/mppa_k1c/vararg.S | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index 9869eb0b..184bd3f8 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -58,7 +58,6 @@ __compcert_acswapw: .globl __compcert_i32_udiv .globl __compcert_i32_umod __compcert_i32_sdiv: -__compcert_i32_smod: __compcert_i32_umod: sxwd $r0 = $r0 sxwd $r1 = $r1 @@ -87,6 +86,38 @@ __compcert_i32_umod: ret ;; +__compcert_i32_smod: + sxwd $r4 = $r0 + sxwd $r5 = $r1 + make $r2 = 0x3ff0000000000000 + ;; + copyd $r0 = $r4 + copyd $r1 = $r5 + floatd.rn.s $r4 = $r4, 0 + ;; + floatd.rn.s $r3 = $r5, 0 + ;; + floatw.rn.s $r5 = $r5, 0 + ;; + finvw $r5=$r5 + ;; + fwidenlwd $r5 = $r5 + ;; + fmuld $r4 = $r4, $r5 + ;; + ffmsd $r2 = $r5, $r3 + copyd $r5 = $r4 + ;; + ffmad $r5 = $r2, $r4 + ;; + ffmad $r4 = $r2, $r5 + ;; + fixedd.rz $r4 = $r4, 0 + ;; + msbfd $r0 = $r1, $r4 + ret + ;; + __compcert_i32_udiv: zxwd $r0 = $r0 zxwd $r1 = $r1 @@ -112,5 +143,6 @@ __compcert_i32_udiv: ffmad $r0 = $r2, $r1 ;; fixedud.rz $r0 = $r0, 0 + ;; ret ;; -- cgit From 742cd4505a6646247bf0740ea4e6ab779972a554 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 May 2019 14:54:17 +0200 Subject: sdiv, smod, udiv, umod through fast routines --- runtime/mppa_k1c/vararg.S | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index 184bd3f8..5804c707 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -58,7 +58,6 @@ __compcert_acswapw: .globl __compcert_i32_udiv .globl __compcert_i32_umod __compcert_i32_sdiv: -__compcert_i32_umod: sxwd $r0 = $r0 sxwd $r1 = $r1 make $r2 = 0x3ff0000000000000 @@ -146,3 +145,35 @@ __compcert_i32_udiv: ;; ret ;; + +__compcert_i32_umod: + zxwd $r4 = $r0 + zxwd $r5 = $r1 + make $r2 = 0x3ff0000000000000 + ;; + copyd $r0 = $r4 + copyd $r1 = $r5 + floatud.rn.s $r4 = $r4, 0 + ;; + floatud.rn.s $r3 = $r5, 0 + ;; + floatuw.rn.s $r5 = $r5, 0 + ;; + finvw $r5=$r5 + ;; + fwidenlwd $r5 = $r5 + ;; + fmuld $r4 = $r4, $r5 + ;; + ffmsd $r2 = $r5, $r3 + copyd $r5 = $r4 + ;; + ffmad $r5 = $r2, $r4 + ;; + ffmad $r4 = $r2, $r5 + ;; + fixedud.rz $r4 = $r4, 0 + ;; + msbfd $r0 = $r1, $r4 + ret + ;; -- cgit From b0ec7472890babc8c439984d75c14f2b4486416a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 May 2019 15:32:45 +0200 Subject: new routines for 32-bit division --- runtime/Makefile | 5 +- runtime/mppa_k1c/i32_divmod.S | 120 ++++++++++++++++++++++++++++++++++++++++++ runtime/mppa_k1c/i64_sdiv.c | 2 - 3 files changed, 122 insertions(+), 5 deletions(-) create mode 100644 runtime/mppa_k1c/i32_divmod.S diff --git a/runtime/Makefile b/runtime/Makefile index 1258d941..2448279e 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -23,9 +23,8 @@ OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),powerpc64) OBJS=i64_dtou.o i64_stof.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),mppa_k1c) -OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o vararg.o\ - i64_dtos.o i64_dtou.o i64_utod.o i64_utof.o i64_stod.o i64_stof.o\ - i64_shl.o i64_shr.o +OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o i32_divmod.o \ + vararg.o # Missing: i64_utod.o i64_utof.o i64_stod.o i64_stof.o DOMAKE:=$(shell (cd mppa_k1c && make)) else diff --git a/runtime/mppa_k1c/i32_divmod.S b/runtime/mppa_k1c/i32_divmod.S new file mode 100644 index 00000000..d5a4c2ca --- /dev/null +++ b/runtime/mppa_k1c/i32_divmod.S @@ -0,0 +1,120 @@ +/* K1C +32-bit unsigned/signed integer division/modulo (udiv5) + +D. Monniaux, CNRS, VERIMAG */ + + + .globl __compcert_i32_sdiv +__compcert_i32_sdiv: + compw.lt $r2 = $r0, 0 + compw.lt $r3 = $r1, 0 + absw $r0 = $r0 + absw $r1 = $r1 + ;; + xord $r2 = $r2, $r3 + make $r3 = 0 + goto __compcert_i32_divmod + ;; + + .globl __compcert_i32_smod +__compcert_i32_smod: + compw.lt $r2 = $r0, 0 + absw $r0 = $r0 + absw $r1 = $r1 + make $r3 = 1 + goto __compcert_i32_divmod + ;; + + .globl __compcert_i32_umod +__compcert_i32_umod: + make $r2 = 0 + make $r3 = 1 + goto __compcert_i32_divmod + ;; + + .globl __compcert_i32_udiv +__compcert_i32_udiv: + make $r2 = 0 + make $r3 = 0 + ;; + +/* +r0 : a +r1 : b +r2 : negate result? +r3 : return mod? +*/ + + .globl __compcert_i32_divmod +__compcert_i32_divmod: + zxwd $r7 = $r1 + zxwd $r1 = $r0 +#ifndef NO_SHORTCUT + compw.ltu $r8 = $r0, $r1 + cb.weqz $r1? .ERR # return 0 if divide by 0 +#endif + ;; +# a in r1, b in r7 + floatud.rn $r5 = $r7, 0 +#ifndef NO_SHORTCUT + compd.eq $r8 = $r7, 1 + cb.wnez $r8? .LESS # shortcut if a < b +#endif + ;; +# b (double) in r5 + make $r6 = 0x3ff0000000000000 # 1.0 + fnarrowdw.rn $r11 = $r5 +# cb.wnez $r8, .RET1 # if b=1 + ;; +# b (single) in r11 + floatud.rn $r10 = $r1, 0 + finvw.rn $r11 = $r11 + ;; + fwidenlwd $r11 = $r11 + ;; +# invb0 in r11 + copyd $r9 = $r11 + ffmsd.rn $r6 = $r11, $r5 +# alpha in r6 + ;; + ffmad.rn $r9 = $r11, $r6 +# 1/b in r9 + ;; + fmuld.rn $r0 = $r10, $r9 +# a/b in r1 + ;; + fixedud.rn $r0 = $r0, 0 + ;; + msbfd $r1 = $r0, $r7 + ;; + addd $r6 = $r0, -1 + addd $r8 = $r1, $r7 + ;; + cmoved.dltz $r1? $r0 = $r6 + cmoved.dltz $r1? $r1 = $r8 + ;; + negw $r4 = $r0 + negw $r5 = $r1 + ;; + cmoved.wnez $r2? $r0 = $r4 + cmoved.wnez $r2? $r1 = $r5 + ;; +.END: + cmoved.wnez $r3? $r0 = $r1 + ret + ;; +#ifndef NO_SHORTCUT + +.LESS: + make $r0 = 0 + negw $r5 = $r1 + ;; + cmoved.wnez $r2? $r1 = $r5 + goto .END + ;; + +.ERR: + make $r0 = 0 + ret + ;; +#endif diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c index 809f2b1c..18a2c46c 100644 --- a/runtime/mppa_k1c/i64_sdiv.c +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -1,5 +1,3 @@ -extern long __divdi3 (long a, long b); - #include /* DM FIXME this is for floating point */ -- cgit From 6141d184274db971f553130703554f0b1b66ef1b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 10:20:24 +0200 Subject: various fixes --- configure | 2 +- runtime/mppa_k1c/i64_sdiv.c | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/configure b/configure index 43c90b47..52fffa63 100755 --- a/configure +++ b/configure @@ -461,7 +461,7 @@ if test "$arch" = "mppa_k1c"; then libdir="$HOME/.usr/lib" clinker_options="$model_options -L$libdir -Wl,-rpath=$libdir" cprepro="$k1base-gcc" - cprepro_options="$model_options -D __K1C_$osupper__ -std=c99 -E -include ccomp_k1c_fixes.h" + cprepro_options="$model_options -D __K1C_${osupper}__ -std=c99 -E -include ccomp_k1c_fixes.h" libmath="-lm" system="linux" fi diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c index d1d268c4..b53294ec 100644 --- a/runtime/mppa_k1c/i64_sdiv.c +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -10,6 +10,7 @@ #include #endif +#ifdef COMPCERT_FE_EXCEPT /* DM FIXME this is for floating point */ int fetestexcept(int excepts) { int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts; @@ -22,3 +23,4 @@ int feclearexcept(int excepts) { __builtin_k1_wfxl(K1_SFR_CS, mask); return 0; } +#endif -- cgit From aa3ff942fb4944242c7a2398592b7e3d33f6c9dc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 10:35:01 +0200 Subject: fixes --- runtime/mppa_k1c/i64_sdiv.c | 1 + 1 file changed, 1 insertion(+) diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c index b53294ec..9fac8ff9 100644 --- a/runtime/mppa_k1c/i64_sdiv.c +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -10,6 +10,7 @@ #include #endif +/* #define COMPCERT_FE_EXCEPT */ #ifdef COMPCERT_FE_EXCEPT /* DM FIXME this is for floating point */ int fetestexcept(int excepts) { -- cgit From 11cd0ace897752ef7ca33609aa1250ca1597185b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 11:14:46 +0200 Subject: arranging for selection of divisor as option --- mppa_k1c/TargetPrinter.ml | 48 ++++++++++++++-- runtime/Makefile | 5 +- runtime/mppa_k1c/i32_divmod.S | 26 ++++----- runtime/mppa_k1c/i64_sdiv.c | 12 +++- runtime/mppa_k1c/i64_smod.c | 5 ++ runtime/mppa_k1c/i64_udiv.c | 6 ++ runtime/mppa_k1c/i64_udivmod.c | 2 + runtime/mppa_k1c/i64_umod.c | 6 ++ runtime/mppa_k1c/vararg.S | 125 ----------------------------------------- 9 files changed, 89 insertions(+), 146 deletions(-) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 96779517..4dc4b7c2 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -34,11 +34,51 @@ module Target (*: TARGET*) = let comment = "#" + type idiv_function_kind = + | Idiv_system + | Idiv_stsud + | Idiv_fp;; + + let idiv_function_kind_32bit () = Idiv_fp;; + let idiv_function_kind_64bit () = Idiv_stsud;; + let subst_symbol = function - "__compcert_i64_udiv" -> "__udivdi3" - | "__compcert_i64_sdiv" -> "__divdi3" - | "__compcert_i64_umod" -> "__umoddi3" - | "__compcert_i64_smod" -> "__moddi3" + "__compcert_i64_udiv" -> + (match idiv_function_kind_64bit () with + | Idiv_system | Idiv_fp -> "__udivdi3" + | Idiv_stsud -> "__compcert_i64_udiv_stsud") + | "__compcert_i64_sdiv" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__divdi3" + | Idiv_stsud -> "__compcert_i64_sdiv_stsud") + | "__compcert_i64_umod" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__umoddi3" + | Idiv_stsud -> "__compcert_i64_umod_stsud") + | "__compcert_i64_smod" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__moddi3" + | Idiv_stsud -> "__compcert_i64_stsud") + | "__compcert_i32_sdiv" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_sdiv_fp" + | Idiv_stsud -> "__compcert_i32_sdiv_stsud") + | "__compcert_i32_udiv" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_udiv_fp" + | Idiv_stsud -> "__compcert_i32_udiv_stsud") + | "__compcert_i32_smod" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_smod_fp" + | Idiv_stsud -> "__compcert_i32_smod_stsud") + | "__compcert_i32_umod" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_umod_fp" + | Idiv_stsud -> "__compcert_i32_umod_stsud") | "__compcert_f64_div" -> "__divdf3" | "__compcert_f32_div" -> "__divsf3" | x -> x;; diff --git a/runtime/Makefile b/runtime/Makefile index 2448279e..6bc3e7ea 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -23,8 +23,9 @@ OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),powerpc64) OBJS=i64_dtou.o i64_stof.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),mppa_k1c) -OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o i32_divmod.o \ - vararg.o +OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o \ + i64_udivmod_stsud.o i32_divmod.o \ + vararg.o # Missing: i64_utod.o i64_utof.o i64_stod.o i64_stof.o DOMAKE:=$(shell (cd mppa_k1c && make)) else diff --git a/runtime/mppa_k1c/i32_divmod.S b/runtime/mppa_k1c/i32_divmod.S index d5a4c2ca..8dd9481c 100644 --- a/runtime/mppa_k1c/i32_divmod.S +++ b/runtime/mppa_k1c/i32_divmod.S @@ -4,8 +4,8 @@ D. Monniaux, CNRS, VERIMAG */ - .globl __compcert_i32_sdiv -__compcert_i32_sdiv: + .globl __compcert_i32_sdiv_fp +__compcert_i32_sdiv_fp: compw.lt $r2 = $r0, 0 compw.lt $r3 = $r1, 0 absw $r0 = $r0 @@ -13,27 +13,27 @@ __compcert_i32_sdiv: ;; xord $r2 = $r2, $r3 make $r3 = 0 - goto __compcert_i32_divmod + goto __compcert_i32_divmod_fp ;; - .globl __compcert_i32_smod -__compcert_i32_smod: + .globl __compcert_i32_smod_fp +__compcert_i32_smod_fp: compw.lt $r2 = $r0, 0 absw $r0 = $r0 absw $r1 = $r1 make $r3 = 1 - goto __compcert_i32_divmod + goto __compcert_i32_divmod_fp ;; - .globl __compcert_i32_umod -__compcert_i32_umod: + .globl __compcert_i32_umod_fp +__compcert_i32_umod_fp: make $r2 = 0 make $r3 = 1 - goto __compcert_i32_divmod + goto __compcert_i32_divmod_fp ;; - .globl __compcert_i32_udiv -__compcert_i32_udiv: + .globl __compcert_i32_udiv_fp +__compcert_i32_udiv_fp: make $r2 = 0 make $r3 = 0 ;; @@ -45,8 +45,8 @@ r2 : negate result? r3 : return mod? */ - .globl __compcert_i32_divmod -__compcert_i32_divmod: + .globl __compcert_i32_divmod_fp +__compcert_i32_divmod_fp: zxwd $r7 = $r1 zxwd $r1 = $r0 #ifndef NO_SHORTCUT diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c index 9fac8ff9..df308736 100644 --- a/runtime/mppa_k1c/i64_sdiv.c +++ b/runtime/mppa_k1c/i64_sdiv.c @@ -1,4 +1,14 @@ +extern long __divdi3 (long a, long b); + +int i32_sdiv (int a, int b) +{ + return __divdi3 (a, b); +} + +/* #define COMPCERT_FE_EXCEPT */ +#ifdef COMPCERT_FE_EXCEPT #ifdef __K1C_COS__ + #include #define K1_SFR_CS_IO_MASK COS_SFR_CS_IO_MASK #define K1_SFR_CS_DZ_MASK COS_SFR_CS_DZ_MASK @@ -10,8 +20,6 @@ #include #endif -/* #define COMPCERT_FE_EXCEPT */ -#ifdef COMPCERT_FE_EXCEPT /* DM FIXME this is for floating point */ int fetestexcept(int excepts) { int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts; diff --git a/runtime/mppa_k1c/i64_smod.c b/runtime/mppa_k1c/i64_smod.c index e69de29b..3371eecf 100644 --- a/runtime/mppa_k1c/i64_smod.c +++ b/runtime/mppa_k1c/i64_smod.c @@ -0,0 +1,5 @@ +extern long __moddi3 (long a, long b); +int i32_smod (int a, int b) +{ + return __moddi3 (a, b); +} diff --git a/runtime/mppa_k1c/i64_udiv.c b/runtime/mppa_k1c/i64_udiv.c index e69de29b..75f4bbf5 100644 --- a/runtime/mppa_k1c/i64_udiv.c +++ b/runtime/mppa_k1c/i64_udiv.c @@ -0,0 +1,6 @@ +extern unsigned long __udivdi3 (unsigned long a, unsigned long b); + +unsigned i32_udiv (unsigned a, unsigned b) +{ + return __udivdi3 (a, b); +} diff --git a/runtime/mppa_k1c/i64_udivmod.c b/runtime/mppa_k1c/i64_udivmod.c index 74b39874..ca48cd87 100644 --- a/runtime/mppa_k1c/i64_udivmod.c +++ b/runtime/mppa_k1c/i64_udivmod.c @@ -1,3 +1,4 @@ +#if 0 /* THIS IS THE PREVIOUS VERSION, USED ON BOSTAN AND ANDEY */ unsigned long long udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) @@ -26,3 +27,4 @@ udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) return modwanted ? r : q; } +#endif diff --git a/runtime/mppa_k1c/i64_umod.c b/runtime/mppa_k1c/i64_umod.c index e69de29b..59e35960 100644 --- a/runtime/mppa_k1c/i64_umod.c +++ b/runtime/mppa_k1c/i64_umod.c @@ -0,0 +1,6 @@ +extern unsigned long __umoddi3 (unsigned long a, unsigned long b); + +unsigned i32_umod (unsigned a, unsigned b) +{ + return __umoddi3 (a, b); +} diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.S index 5804c707..9e23e0b3 100644 --- a/runtime/mppa_k1c/vararg.S +++ b/runtime/mppa_k1c/vararg.S @@ -52,128 +52,3 @@ __compcert_acswapw: sq 0[$r0] = $r2r3 ret ;; - - .globl __compcert_i32_sdiv - .globl __compcert_i32_smod - .globl __compcert_i32_udiv - .globl __compcert_i32_umod -__compcert_i32_sdiv: - sxwd $r0 = $r0 - sxwd $r1 = $r1 - make $r2 = 0x3ff0000000000000 - ;; - floatd.rn.s $r0 = $r0, 0 - ;; - floatd.rn.s $r3 = $r1, 0 - ;; - floatw.rn.s $r1 = $r1, 0 - ;; - finvw $r1=$r1 - ;; - fwidenlwd $r1 = $r1 - ;; - fmuld $r0 = $r0, $r1 - ;; - ffmsd $r2 = $r1, $r3 - copyd $r1 = $r0 - ;; - ffmad $r1 = $r2, $r0 - ;; - ffmad $r0 = $r2, $r1 - ;; - fixedd.rz $r0 = $r0, 0 - ret - ;; - -__compcert_i32_smod: - sxwd $r4 = $r0 - sxwd $r5 = $r1 - make $r2 = 0x3ff0000000000000 - ;; - copyd $r0 = $r4 - copyd $r1 = $r5 - floatd.rn.s $r4 = $r4, 0 - ;; - floatd.rn.s $r3 = $r5, 0 - ;; - floatw.rn.s $r5 = $r5, 0 - ;; - finvw $r5=$r5 - ;; - fwidenlwd $r5 = $r5 - ;; - fmuld $r4 = $r4, $r5 - ;; - ffmsd $r2 = $r5, $r3 - copyd $r5 = $r4 - ;; - ffmad $r5 = $r2, $r4 - ;; - ffmad $r4 = $r2, $r5 - ;; - fixedd.rz $r4 = $r4, 0 - ;; - msbfd $r0 = $r1, $r4 - ret - ;; - -__compcert_i32_udiv: - zxwd $r0 = $r0 - zxwd $r1 = $r1 - make $r2 = 0x3ff0000000000000 - ;; - floatud.rn.s $r0 = $r0, 0 - ;; - floatud.rn.s $r3 = $r1, 0 - ;; - floatuw.rn.s $r1 = $r1, 0 - ;; - finvw $r1=$r1 - ;; - fwidenlwd $r1 = $r1 - ;; - fmuld $r0 = $r0, $r1 - ;; - ffmsd $r2 = $r1, $r3 - copyd $r1 = $r0 - ;; - ffmad $r1 = $r2, $r0 - ;; - ffmad $r0 = $r2, $r1 - ;; - fixedud.rz $r0 = $r0, 0 - ;; - ret - ;; - -__compcert_i32_umod: - zxwd $r4 = $r0 - zxwd $r5 = $r1 - make $r2 = 0x3ff0000000000000 - ;; - copyd $r0 = $r4 - copyd $r1 = $r5 - floatud.rn.s $r4 = $r4, 0 - ;; - floatud.rn.s $r3 = $r5, 0 - ;; - floatuw.rn.s $r5 = $r5, 0 - ;; - finvw $r5=$r5 - ;; - fwidenlwd $r5 = $r5 - ;; - fmuld $r4 = $r4, $r5 - ;; - ffmsd $r2 = $r5, $r3 - copyd $r5 = $r4 - ;; - ffmad $r5 = $r2, $r4 - ;; - ffmad $r4 = $r2, $r5 - ;; - fixedud.rz $r4 = $r4, 0 - ;; - msbfd $r0 = $r1, $r4 - ret - ;; -- cgit From d075968e1e516ab80460afce57c9bcc15d206c19 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 11:43:29 +0200 Subject: added -fdiv-i32 and -fdiv-i64 options --- driver/Clflags.ml | 3 +++ driver/Driver.ml | 12 +++++++++--- mppa_k1c/TargetPrinter.ml | 10 ++++++++-- 3 files changed, 20 insertions(+), 5 deletions(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index b1afab6f..fd5f0e68 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -71,3 +71,6 @@ let option_fglobaladdrtmp = ref false let option_fglobaladdroffset = ref false let option_fxsaddr = ref true let option_coalesce_mem = ref true + +let option_div_i32 = ref "stsud" +let option_div_i64 = ref "stsud" diff --git a/driver/Driver.ml b/driver/Driver.ml index cfafcaa3..314cf31c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -265,9 +265,13 @@ let num_input_files = ref 0 let cmdline_actions = let f_opt name ref = [Exact("-f" ^ name), Set ref; Exact("-fno-" ^ name), Unset ref] in - let f_opt_str name ref strref = + let f_opt_str name ref strref default = [Exact("-f" ^ name ^ "="), String - (fun s -> (strref := (if s == "" then "list" else s)); ref := true) + (fun s -> (strref := (if s == "" then default else s)); ref := true) + ] in + let f_str name strref default = + [Exact("-f" ^ name ^ "="), String + (fun s -> (strref := (if s == "" then default else s))) ] in [ (* Getting help *) @@ -369,13 +373,15 @@ let cmdline_actions = @ f_opt "cse" option_fcse @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass - @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched + @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched "list" @ f_opt "inline" option_finline @ f_opt "inline-functions-called-once" option_finline_functions_called_once @ f_opt "globaladdrtmp" option_fglobaladdrtmp @ f_opt "globaladdroffset" option_fglobaladdroffset @ f_opt "xsaddr" option_fxsaddr @ f_opt "coalesce-mem" option_coalesce_mem + @ f_str "div-i32" option_div_i32 "stsud" + @ f_str "div-i64" option_div_i64 "stsud" (* Code generation options *) @ f_opt "fpu" option_ffpu @ f_opt "sse" option_ffpu (* backward compatibility *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 4dc4b7c2..2bdd0978 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -39,8 +39,14 @@ module Target (*: TARGET*) = | Idiv_stsud | Idiv_fp;; - let idiv_function_kind_32bit () = Idiv_fp;; - let idiv_function_kind_64bit () = Idiv_stsud;; + let idiv_function_kind = function + "stsud" -> Idiv_stsud + | "system" -> Idiv_system + | "fp" -> Idiv_fp + | _ -> failwith "unknown integer division kind";; + + let idiv_function_kind_32bit () = idiv_function_kind !Clflags.option_div_i32;; + let idiv_function_kind_64bit () = idiv_function_kind !Clflags.option_div_i64;; let subst_symbol = function "__compcert_i64_udiv" -> -- cgit From 6b874a7d5867fc8da503b6658f2fb179c5a12a6b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 12:08:24 +0200 Subject: use silent FP --- runtime/mppa_k1c/i32_divmod.S | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/runtime/mppa_k1c/i32_divmod.S b/runtime/mppa_k1c/i32_divmod.S index 8dd9481c..d2b4e8d5 100644 --- a/runtime/mppa_k1c/i32_divmod.S +++ b/runtime/mppa_k1c/i32_divmod.S @@ -55,7 +55,7 @@ __compcert_i32_divmod_fp: #endif ;; # a in r1, b in r7 - floatud.rn $r5 = $r7, 0 + floatud.rn.s $r5 = $r7, 0 #ifndef NO_SHORTCUT compd.eq $r8 = $r7, 1 cb.wnez $r8? .LESS # shortcut if a < b @@ -63,27 +63,27 @@ __compcert_i32_divmod_fp: ;; # b (double) in r5 make $r6 = 0x3ff0000000000000 # 1.0 - fnarrowdw.rn $r11 = $r5 + fnarrowdw.rn.s $r11 = $r5 # cb.wnez $r8, .RET1 # if b=1 ;; # b (single) in r11 - floatud.rn $r10 = $r1, 0 - finvw.rn $r11 = $r11 + floatud.rn.s $r10 = $r1, 0 + finvw.rn.s $r11 = $r11 ;; - fwidenlwd $r11 = $r11 + fwidenlwd.s $r11 = $r11 ;; # invb0 in r11 copyd $r9 = $r11 - ffmsd.rn $r6 = $r11, $r5 + ffmsd.rn.s $r6 = $r11, $r5 # alpha in r6 ;; - ffmad.rn $r9 = $r11, $r6 + ffmad.rn.s $r9 = $r11, $r6 # 1/b in r9 ;; - fmuld.rn $r0 = $r10, $r9 + fmuld.rn.s $r0 = $r10, $r9 # a/b in r1 ;; - fixedud.rn $r0 = $r0, 0 + fixedud.rn.s $r0 = $r0, 0 ;; msbfd $r1 = $r0, $r7 ;; -- cgit From 633b72565b022f159526338b5bbb9fcac86dfd2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 29 May 2019 21:22:55 +0200 Subject: copyright block --- runtime/mppa_k1c/i64_udivmod_stsud.S | 183 +++++++++++++++++++++++++++++++++++ 1 file changed, 183 insertions(+) create mode 100644 runtime/mppa_k1c/i64_udivmod_stsud.S diff --git a/runtime/mppa_k1c/i64_udivmod_stsud.S b/runtime/mppa_k1c/i64_udivmod_stsud.S new file mode 100644 index 00000000..ac84ca47 --- /dev/null +++ b/runtime/mppa_k1c/i64_udivmod_stsud.S @@ -0,0 +1,183 @@ +/* +Integer division for K1c + +David Monniaux, CNRS / Verimag + */ + + .globl dm_udivmoddi4 +dm_udivmoddi4: + sxwd $r2 = $r2 + make $r5 = 0 + compd.ltu $r3 = $r0, $r1 + ;; + + clzd $r3 = $r1 + clzd $r4 = $r0 + cb.dnez $r3? .L74 + ;; + + sbfw $r4 = $r4, $r3 + ;; + + zxwd $r3 = $r4 + slld $r1 = $r1, $r4 + ;; + + compd.ltu $r6 = $r0, $r1 + ;; + + cb.dnez $r6? .L4C + ;; + + make $r5 = 1 + sbfd $r0 = $r1, $r0 + ;; + + slld $r5 = $r5, $r4 + ;; + +.L4C: + cb.deqz $r3? .L74 + ;; + + srld $r1 = $r1, 1 + zxwd $r3 = $r4 + ;; + + loopdo $r3, .LOOP + ;; + + stsud $r0 = $r1, $r0 + ;; + +.LOOP: + addd $r5 = $r0, $r5 + srld $r0 = $r0, $r4 + ;; + + slld $r4 = $r0, $r4 + ;; + + sbfd $r5 = $r4, $r5 + ;; + +.L74: + cmoved.deqz $r2? $r0 = $r5 + ret + ;; + +/* +r0 : a +r1 : b +r2 : negate result? +r3 : return mod? +*/ + + .globl __compcert_i32_sdiv_stsud +__compcert_i32_sdiv_stsud: + compw.lt $r2 = $r0, 0 + compw.lt $r3 = $r1, 0 + absw $r0 = $r0 + absw $r1 = $r1 + ;; + zxwd $r0 = $r0 + zxwd $r1 = $r1 + xord $r2 = $r2, $r3 + make $r3 = 0 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_smod_stsud +__compcert_i32_smod_stsud: + compw.lt $r2 = $r0, 0 + absw $r0 = $r0 + absw $r1 = $r1 + make $r3 = 1 + ;; + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_umod_stsud +__compcert_i32_umod_stsud: + make $r2 = 0 + make $r3 = 1 + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_udiv_stsud +__compcert_i32_udiv_stsud: + make $r2 = 0 + make $r3 = 0 + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_divmod_stsud + __compcert_i64_divmod_stsud: + make $r5 = 0 + compd.ltu $r7 = $r0, $r1 + ;; + + clzd $r7 = $r1 + clzd $r4 = $r0 + cb.dnez $r7? .ZL74 + ;; + + sbfw $r4 = $r4, $r7 + ;; + + zxwd $r7 = $r4 + slld $r1 = $r1, $r4 + ;; + + compd.ltu $r6 = $r0, $r1 + ;; + + cb.dnez $r6? .ZL4C + ;; + + make $r5 = 1 + sbfd $r0 = $r1, $r0 + ;; + + slld $r5 = $r5, $r4 + ;; + +.ZL4C: + cb.deqz $r7? .ZL74 + ;; + + srld $r1 = $r1, 1 + zxwd $r7 = $r4 + ;; + + loopdo $r7, .ZLOOP + ;; + + stsud $r0 = $r1, $r0 + ;; + +.ZLOOP: + addd $r5 = $r0, $r5 + srld $r0 = $r0, $r4 + ;; + + slld $r4 = $r0, $r4 + ;; + + sbfd $r5 = $r4, $r5 + ;; + +.ZL74: + cmoved.weqz $r3? $r0 = $r5 + ;; + negd $r5 = $r0 + ;; + cmoved.wnez $r2? $r0 = $r5 + ret + ;; -- cgit From c420bc8d3b87d71c38209b5ab8bca22875466362 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 25 Sep 2019 21:31:57 +0200 Subject: __builtin_expect defined as its first argument --- backend/Selection.v | 3 ++- backend/Selectionproof.v | 7 +++++++ cfrontend/C2C.ml | 5 +++-- common/Builtins0.v | 8 +++++++- runtime/include/ccomp_k1c_fixes.h | 2 +- 5 files changed, 20 insertions(+), 5 deletions(-) diff --git a/backend/Selection.v b/backend/Selection.v index 4ab3331e..7ba8fe92 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -243,7 +243,8 @@ Definition sel_builtin_res (optid: option ident) : builtin_res ident := Function sel_known_builtin (bf: builtin_function) (args: exprlist) := match bf, args with | BI_platform b, _ => - SelectOp.platform_builtin b args + SelectOp.platform_builtin b args + | BI_standard BI_expect, a1 ::: a2 ::: Enil => Some a1 | BI_standard (BI_select ty), a1 ::: a2 ::: a3 ::: Enil => Some (sel_select ty a1 a2 a3) | BI_standard BI_fabs, a1 ::: Enil => diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 8a827af2..0be96167 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -395,6 +395,13 @@ Proof. inv ARGS; try discriminate. inv H0; try discriminate. inv SEL. simpl in SEM; inv SEM. apply eval_absf; auto. ++ (* expect *) + inv ARGS; try discriminate. + inv H0; try discriminate. + inv H2; try discriminate. + simpl in SEM. inv SEM. inv SEL. + destruct v1; destruct v0. + all: econstructor; split; eauto. - eapply eval_platform_builtin; eauto. Qed. diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index dc25b516..421c4b07 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -157,9 +157,10 @@ let ais_annot_functions = let builtins_generic = { builtin_typedefs = []; builtin_functions = - ais_annot_functions - @ + ais_annot_functions @ [ + "__builtin_expect", + (TInt(ILong, []), [TInt(ILong, []); TInt(ILong, [])], false); (* Integer arithmetic *) "__builtin_bswap64", (TInt(IULongLong, []), [TInt(IULongLong, [])], false); diff --git a/common/Builtins0.v b/common/Builtins0.v index b78006dd..5061bf43 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -337,6 +337,7 @@ Inductive standard_builtin : Type := | BI_addl | BI_subl | BI_mull + | BI_expect | BI_i16_bswap | BI_i32_bswap | BI_i64_bswap @@ -373,6 +374,7 @@ Definition standard_builtin_table : list (string * standard_builtin) := :: ("__builtin_bswap", BI_i32_bswap) :: ("__builtin_bswap32", BI_i32_bswap) :: ("__builtin_bswap64", BI_i64_bswap) + :: ("__builtin_expect", BI_expect) :: ("__compcert_i64_umulh", BI_i64_umulh) :: ("__compcert_i64_smulh", BI_i64_smulh) :: ("__compcert_i64_sdiv", BI_i64_sdiv) @@ -402,7 +404,9 @@ Definition standard_builtin_sig (b: standard_builtin) : signature := | BI_i64_sdiv | BI_i64_udiv | BI_i64_smod | BI_i64_umod => mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default | BI_mull => - mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default + mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default + | BI_expect => + mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default | BI_i32_bswap => mksignature (Tint :: nil) (Some Tint) cc_default | BI_i64_bswap => @@ -433,6 +437,8 @@ Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (pro | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _ | BI_subl => mkbuiltin_v2t Tlong Val.subl _ _ | BI_mull => mkbuiltin_v2t Tlong Val.mull' _ _ + | BI_expect => + mkbuiltin_n2t Tlong Tlong Tlong (fun x _ => x) | BI_i16_bswap => mkbuiltin_n1t Tint Tint (fun n => Int.repr (decode_int (List.rev (encode_int 2%nat (Int.unsigned n))))) diff --git a/runtime/include/ccomp_k1c_fixes.h b/runtime/include/ccomp_k1c_fixes.h index 718ac3e5..f3fa11fe 100644 --- a/runtime/include/ccomp_k1c_fixes.h +++ b/runtime/include/ccomp_k1c_fixes.h @@ -25,6 +25,6 @@ extern long long __compcert_afaddd(void *address, unsigned long long incr); extern int __compcert_afaddw(void *address, unsigned int incr); #endif -#define __builtin_expect(x, y) (x) +/* #define __builtin_expect(x, y) (x) */ #define __builtin_ctz(x) __builtin_k1_ctzw(x) #define __builtin_clz(x) __builtin_k1_clzw(x) -- cgit From e08273dcd62dca09c401fb80517652a657028ef9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 20 Feb 2020 21:49:53 +0100 Subject: fast configuration files --- config_rv32.sh | 1 + config_simple.sh | 6 ++++++ 2 files changed, 7 insertions(+) create mode 100755 config_rv32.sh create mode 100755 config_simple.sh diff --git a/config_rv32.sh b/config_rv32.sh new file mode 100755 index 00000000..a5a5cf1c --- /dev/null +++ b/config_rv32.sh @@ -0,0 +1 @@ +exec ./config_simple.sh rv32-linux --toolprefix riscv64-linux-gnu- "$@" diff --git a/config_simple.sh b/config_simple.sh new file mode 100755 index 00000000..f02680c4 --- /dev/null +++ b/config_simple.sh @@ -0,0 +1,6 @@ +arch=$1 +shift +version=`git rev-parse --short HEAD` +branch=`git rev-parse --abbrev-ref HEAD` +date=`date -I` +./configure --prefix /opt/CompCert/${branch}/${date}_${version}/$arch "$@" $arch -- cgit From 41884d0591b185c59098096a8749d614cfafbe1d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 08:19:55 +0100 Subject: configure scripts --- config_aarch64.sh | 1 + config_arm.sh | 1 + config_k1c.sh | 1 + config_ppc.sh | 1 + config_rv32.sh | 2 +- config_rv64.sh | 1 + 6 files changed, 6 insertions(+), 1 deletion(-) create mode 100755 config_aarch64.sh create mode 100755 config_arm.sh create mode 100755 config_k1c.sh create mode 100755 config_ppc.sh create mode 100755 config_rv64.sh diff --git a/config_aarch64.sh b/config_aarch64.sh new file mode 100755 index 00000000..ded267bf --- /dev/null +++ b/config_aarch64.sh @@ -0,0 +1 @@ +exec ./config_simple.sh aarch64-linux --toolprefix aarch64-linux-gnu- "$@" diff --git a/config_arm.sh b/config_arm.sh new file mode 100755 index 00000000..eed55fab --- /dev/null +++ b/config_arm.sh @@ -0,0 +1 @@ +exec ./config_simple.sh arm-linux --toolprefix arm-linux-gnueabihf- "$@" diff --git a/config_k1c.sh b/config_k1c.sh new file mode 100755 index 00000000..20408397 --- /dev/null +++ b/config_k1c.sh @@ -0,0 +1 @@ +exec ./config_simple.sh k1c-cos "$@" diff --git a/config_ppc.sh b/config_ppc.sh new file mode 100755 index 00000000..d597cda5 --- /dev/null +++ b/config_ppc.sh @@ -0,0 +1 @@ +exec ./config_simple.sh ppc-linux --toolprefix powerpc-linux-gnu- "$@" diff --git a/config_rv32.sh b/config_rv32.sh index a5a5cf1c..654cacfa 100755 --- a/config_rv32.sh +++ b/config_rv32.sh @@ -1 +1 @@ -exec ./config_simple.sh rv32-linux --toolprefix riscv64-linux-gnu- "$@" +exec ./config_simple.sh rv32-linux --toolprefix riscv64-unknown-elf- "$@" diff --git a/config_rv64.sh b/config_rv64.sh new file mode 100755 index 00000000..e95f8a70 --- /dev/null +++ b/config_rv64.sh @@ -0,0 +1 @@ +exec ./config_simple.sh rv64-linux --toolprefix riscv64-unknown-elf- "$@" -- cgit From 6d5cb17b6500939c23edb54981fe3a5d60c2ac1a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 08:52:04 +0100 Subject: fix --- mppa_k1c/Conventions1.v | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index d41f1095..30dd8666 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -90,12 +90,17 @@ Definition is_float_reg (r: mreg) := false. returned value. We treat a function without result as a function with one integer result. *) + Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | None => One R0 - | Some (Tint | Tany32) => One R0 - | Some (Tfloat | Tsingle | Tany64) => One R0 - | Some Tlong => if Archi.ptr64 then One R0 else One R0 + match s.(sig_res) with + | Tvoid => One R0 + | Tint8signed => One R0 + | Tint8unsigned => One R0 + | Tint16signed => One R0 + | Tint16unsigned => One R0 + | Tint | Tany32 => One R0 + | Tfloat | Tsingle | Tany64 => One R0 + | Tlong => if Archi.ptr64 then One R0 else One R0 end. (** The result registers have types compatible with that given in the signature. *) @@ -104,8 +109,8 @@ Lemma loc_result_type: forall sig, subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. Proof. - intros. unfold proj_sig_res, loc_result, mreg_type; - destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto. + intros. unfold proj_sig_res, loc_result, mreg_type. + destruct (sig_res sig); try destruct Archi.ptr64; simpl; trivial; destruct t; trivial. Qed. (** The result locations are caller-save registers *) -- cgit From 4437accc3ce393a7dbeda34b51f3507ba6c4f47f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 08:53:34 +0100 Subject: fix --- mppa_k1c/Conventions1.v | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 30dd8666..9e9bae6f 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -120,7 +120,7 @@ Lemma loc_result_caller_save: forall_rpair (fun r => is_callee_save r = false) (loc_result s). Proof. intros. unfold loc_result, is_callee_save; - destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto. + destruct (sig_res s); simpl; auto; try destruct Archi.ptr64; simpl; auto; try destruct t; simpl; auto. Qed. (** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) @@ -130,14 +130,15 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Some Tlong + r1 <> r2 /\ sg.(sig_res) = Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true /\ Archi.ptr64 = false end. Proof. intros. - unfold loc_result; destruct (sig_res sg) as [[]|]; auto. - unfold mreg_type; destruct Archi.ptr64; auto. + unfold loc_result; destruct (sig_res sg); auto; + unfold mreg_type; try destruct Archi.ptr64; auto; + destruct t; auto. Qed. (** The location of the result depends only on the result part of the signature *) -- cgit From 82be9309276a2de2cff6ab96ef7f7b74bb34ffbb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 09:44:00 +0100 Subject: during merge; still some typing issues --- backend/OpHelpers.v | 20 ++++++++++---------- backend/SplitLong.vp | 2 ++ mppa_k1c/Builtins1.v | 12 ++++++------ mppa_k1c/Conventions1.v | 3 +++ 4 files changed, 21 insertions(+), 16 deletions(-) diff --git a/backend/OpHelpers.v b/backend/OpHelpers.v index 53414dab..b9b97903 100644 --- a/backend/OpHelpers.v +++ b/backend/OpHelpers.v @@ -6,16 +6,16 @@ Require Import Op CminorSel. runtime library functions. The following type class collects the names of these functions. *) -Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default. -Definition sig_l_f := mksignature (Tlong :: nil) (Some Tfloat) cc_default. -Definition sig_l_s := mksignature (Tlong :: nil) (Some Tsingle) cc_default. -Definition sig_f_l := mksignature (Tfloat :: nil) (Some Tlong) cc_default. -Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default. -Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default. -Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default. -Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default. -Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default. -Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default. +Definition sig_l_l := mksignature (Tlong :: nil) Tlong cc_default. +Definition sig_l_f := mksignature (Tlong :: nil) Tfloat cc_default. +Definition sig_l_s := mksignature (Tlong :: nil) Tsingle cc_default. +Definition sig_f_l := mksignature (Tfloat :: nil) Tlong cc_default. +Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) Tlong cc_default. +Definition sig_li_l := mksignature (Tlong :: Tint :: nil) Tlong cc_default. +Definition sig_ii_l := mksignature (Tint :: Tint :: nil) Tlong cc_default. +Definition sig_ii_i := mksignature (Tint :: Tint :: nil) Tint cc_default. +Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default. +Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default. Class helper_functions := mk_helper_functions { i64_dtos: ident; (**r float64 -> signed long *) diff --git a/backend/SplitLong.vp b/backend/SplitLong.vp index 73e22b98..4464bcdb 100644 --- a/backend/SplitLong.vp +++ b/backend/SplitLong.vp @@ -22,6 +22,7 @@ Require Import SelectOp. Local Open Scope cminorsel_scope. Local Open Scope string_scope. +(* (** Some operations on 64-bit integers are transformed into calls to runtime library functions. The following type class collects the names of these functions. *) @@ -51,6 +52,7 @@ Definition sig_f_l := mksignature (Tfloat :: nil) Tlong cc_default. Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) Tlong cc_default. Definition sig_li_l := mksignature (Tlong :: Tint :: nil) Tlong cc_default. Definition sig_ii_l := mksignature (Tint :: Tint :: nil) Tlong cc_default. +*) Section SELECT. diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 6186961f..3b5cd419 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -43,18 +43,18 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with | BI_fmin | BI_fmax => - mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default | BI_fminf | BI_fmaxf => - mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default | BI_fabsf => - mksignature (Tsingle :: nil) (Some Tsingle) cc_default + mksignature (Tsingle :: nil) Tsingle cc_default | BI_fma => - mksignature (Tfloat :: Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default + mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default | BI_fmaf => - mksignature (Tsingle :: Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default + mksignature (Tsingle :: Tsingle :: Tsingle :: nil) Tsingle cc_default end. -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (proj_sig_res (platform_builtin_sig b)) := +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 9e9bae6f..ac2117d0 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -415,3 +415,6 @@ Lemma loc_arguments_main: Proof. reflexivity. Qed. + + +Definition return_value_needs_normalization (t: rettype) : bool := false. -- cgit From 66de649c75bc5625f0eab42d299f2281a3872510 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 09:58:47 +0100 Subject: fixed typing issues --- mppa_k1c/Conventions1.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index ac2117d0..48346a6d 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -130,7 +130,7 @@ Lemma loc_result_pair: match loc_result sg with | One _ => True | Twolong r1 r2 => - r1 <> r2 /\ sg.(sig_res) = Tlong + r1 <> r2 /\ proj_sig_res sg = Tlong /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true /\ Archi.ptr64 = false end. -- cgit From 0cbfc9bd7d6b1878e5ff14fe8b8cc41ae07cdbec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 09:59:26 +0100 Subject: rm commented out block --- backend/SplitLong.vp | 32 -------------------------------- 1 file changed, 32 deletions(-) diff --git a/backend/SplitLong.vp b/backend/SplitLong.vp index 4464bcdb..dfe42df0 100644 --- a/backend/SplitLong.vp +++ b/backend/SplitLong.vp @@ -22,38 +22,6 @@ Require Import SelectOp. Local Open Scope cminorsel_scope. Local Open Scope string_scope. -(* -(** Some operations on 64-bit integers are transformed into calls to - runtime library functions. The following type class collects - the names of these functions. *) - -Class helper_functions := mk_helper_functions { - i64_dtos: ident; (**r float64 -> signed long *) - i64_dtou: ident; (**r float64 -> unsigned long *) - i64_stod: ident; (**r signed long -> float64 *) - i64_utod: ident; (**r unsigned long -> float64 *) - i64_stof: ident; (**r signed long -> float32 *) - i64_utof: ident; (**r unsigned long -> float32 *) - i64_sdiv: ident; (**r signed division *) - i64_udiv: ident; (**r unsigned division *) - i64_smod: ident; (**r signed remainder *) - i64_umod: ident; (**r unsigned remainder *) - i64_shl: ident; (**r shift left *) - i64_shr: ident; (**r shift right unsigned *) - i64_sar: ident; (**r shift right signed *) - i64_umulh: ident; (**r unsigned multiply high *) - i64_smulh: ident; (**r signed multiply high *) -}. - -Definition sig_l_l := mksignature (Tlong :: nil) Tlong cc_default. -Definition sig_l_f := mksignature (Tlong :: nil) Tfloat cc_default. -Definition sig_l_s := mksignature (Tlong :: nil) Tsingle cc_default. -Definition sig_f_l := mksignature (Tfloat :: nil) Tlong cc_default. -Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) Tlong cc_default. -Definition sig_li_l := mksignature (Tlong :: Tint :: nil) Tlong cc_default. -Definition sig_ii_l := mksignature (Tint :: Tint :: nil) Tlong cc_default. -*) - Section SELECT. Context {hf: helper_functions}. -- cgit From 01a07b1c68f108df1376beaafdc3242b629634de Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 10:22:19 +0100 Subject: more scripts --- config_ia32.sh | 1 + config_x86_64.sh | 1 + 2 files changed, 2 insertions(+) create mode 100755 config_ia32.sh create mode 100755 config_x86_64.sh diff --git a/config_ia32.sh b/config_ia32.sh new file mode 100755 index 00000000..b40f2b39 --- /dev/null +++ b/config_ia32.sh @@ -0,0 +1 @@ +exec ./config_simple.sh ia32-linux "$@" diff --git a/config_x86_64.sh b/config_x86_64.sh new file mode 100755 index 00000000..b18ec95b --- /dev/null +++ b/config_x86_64.sh @@ -0,0 +1 @@ +exec ./config_simple.sh x86_64-linux "$@" -- cgit From ba21b0ae95189f2d40cca38c502c1ca583a0e1bb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 14:31:06 +0100 Subject: parse _Thread_local --- cparser/Cabs.v | 2 +- cparser/Elab.ml | 2 ++ cparser/Lexer.mll | 2 ++ cparser/Parser.vy | 4 +++- cparser/deLexer.ml | 1 + cparser/pre_parser.mly | 3 ++- test/monniaux/thread_local/thread_local.c | 1 + 7 files changed, 12 insertions(+), 3 deletions(-) create mode 100644 test/monniaux/thread_local/thread_local.c diff --git a/cparser/Cabs.v b/cparser/Cabs.v index 5f12e8a1..2dae061a 100644 --- a/cparser/Cabs.v +++ b/cparser/Cabs.v @@ -54,7 +54,7 @@ Inductive typeSpecifier := (* Merge all specifiers into one type *) | Tenum : option string -> option (list (string * option expression * loc)) -> list attribute -> typeSpecifier with storage := - AUTO | STATIC | EXTERN | REGISTER | TYPEDEF + AUTO | STATIC | EXTERN | REGISTER | TYPEDEF | THREAD_LOCAL with cvspec := | CV_CONST | CV_VOLATILE | CV_RESTRICT diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 3dbb9d45..b76a61cb 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -626,6 +626,7 @@ let rec elab_specifier ?(only = false) loc env specifier = - a set of attributes (const, volatile, restrict) - a list of type specifiers *) let sto = ref Storage_default + and thread_local = ref false and inline = ref false and noreturn = ref false and restrict = ref false @@ -645,6 +646,7 @@ let rec elab_specifier ?(only = false) loc env specifier = | STATIC -> sto := Storage_static | EXTERN -> sto := Storage_extern | REGISTER -> sto := Storage_register + | THREAD_LOCAL -> thread_local := true | TYPEDEF -> if !typedef then error loc "multiple uses of 'typedef'"; diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll index 346477b5..2266a874 100644 --- a/cparser/Lexer.mll +++ b/cparser/Lexer.mll @@ -72,6 +72,7 @@ let () = ("goto", fun loc -> GOTO loc); ("if", fun loc -> IF loc); ("inline", fun loc -> INLINE loc); + ("_Thread_local", fun loc -> THREAD_LOCAL loc); ("_Noreturn", fun loc -> NORETURN loc); ("int", fun loc -> INT loc); ("long", fun loc -> LONG loc); @@ -542,6 +543,7 @@ and singleline_comment = parse | Pre_parser.IF loc -> loop (Parser.IF_ loc) | Pre_parser.INC loc -> loop (Parser.INC loc) | Pre_parser.INLINE loc -> loop (Parser.INLINE loc) + | Pre_parser.THREAD_LOCAL loc -> loop (Parser.THREAD_LOCAL loc) | Pre_parser.INT loc -> loop (Parser.INT loc) | Pre_parser.LBRACE loc -> loop (Parser.LBRACE loc) | Pre_parser.LBRACK loc -> loop (Parser.LBRACK loc) diff --git a/cparser/Parser.vy b/cparser/Parser.vy index 03bfa590..4f3b9789 100644 --- a/cparser/Parser.vy +++ b/cparser/Parser.vy @@ -32,7 +32,7 @@ Require Cabs. LEFT_ASSIGN RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN %token LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA - SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE + SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE THREAD_LOCAL NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID STRUCT UNION ENUM UNDERSCORE_BOOL PACKED ALIGNAS ATTRIBUTE ASM @@ -397,6 +397,8 @@ storage_class_specifier: { (Cabs.AUTO, loc) } | loc = REGISTER { (Cabs.REGISTER, loc) } +| loc = THREAD_LOCAL + { (Cabs.THREAD_LOCAL, loc) } (* 6.7.2 *) type_specifier: diff --git a/cparser/deLexer.ml b/cparser/deLexer.ml index de0e9b6e..43c1a679 100644 --- a/cparser/deLexer.ml +++ b/cparser/deLexer.ml @@ -30,6 +30,7 @@ let delex (symbol : string) : string = | "BUILTIN_VA_ARG" -> "__builtin_va_arg" | "CONST" -> "const" | "INLINE" -> "inline" + | "THREAD_LOCAL" -> "_Thread_local" | "PACKED" -> "__packed__" | "RESTRICT" -> "restrict" | "SIGNED" -> "signed" diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly index 669ecf5e..e21a3519 100644 --- a/cparser/pre_parser.mly +++ b/cparser/pre_parser.mly @@ -54,7 +54,7 @@ COLON AND MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN LEFT_ASSIGN RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT - AUTO REGISTER INLINE NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE + AUTO REGISTER INLINE THREAD_LOCAL NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE UNDERSCORE_BOOL CONST VOLATILE VOID STRUCT UNION ENUM CASE DEFAULT IF ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK RETURN BUILTIN_VA_ARG ALIGNOF ATTRIBUTE ALIGNAS PACKED ASM BUILTIN_OFFSETOF @@ -430,6 +430,7 @@ storage_class_specifier_no_typedef: | STATIC | AUTO | REGISTER +| THREAD_LOCAL {} (* [declaration_specifier_no_type] matches declaration specifiers diff --git a/test/monniaux/thread_local/thread_local.c b/test/monniaux/thread_local/thread_local.c new file mode 100644 index 00000000..0c50f216 --- /dev/null +++ b/test/monniaux/thread_local/thread_local.c @@ -0,0 +1 @@ +_Thread_local int toto; -- cgit From 034eff1d4d4f168008cded71b73bd39066b97997 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 15:56:16 +0100 Subject: begin implementing thread_local storage --- cparser/C.mli | 3 +++ cparser/Ceval.ml | 4 +++- cparser/Cleanup.ml | 6 +++--- cparser/Cprint.ml | 3 +++ cparser/Elab.ml | 21 +++++++++++++++++++-- 5 files changed, 31 insertions(+), 6 deletions(-) diff --git a/cparser/C.mli b/cparser/C.mli index 15717565..3c271f3f 100644 --- a/cparser/C.mli +++ b/cparser/C.mli @@ -86,8 +86,11 @@ type attributes = attribute list type storage = | Storage_default (* used for toplevel names without explicit storage *) + | Storage_thread_local | Storage_extern | Storage_static + | Storage_thread_local_extern + | Storage_thread_local_static | Storage_auto (* used for block-scoped names without explicit storage *) | Storage_register diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml index ecf83779..7bae2fe2 100644 --- a/cparser/Ceval.ml +++ b/cparser/Ceval.ml @@ -354,7 +354,9 @@ and is_constant_lval env e = begin match Env.find_ident env id with | Env.II_ident(sto, _) -> begin match sto with - | Storage_default | Storage_extern | Storage_static -> true + | Storage_default | Storage_extern | Storage_static + | Storage_thread_local | Storage_thread_local_extern | Storage_thread_local_static + -> true | Storage_auto | Storage_register -> false end | Env.II_enum _ -> false (* should not happen *) diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml index 63ac8ac1..b15e150c 100644 --- a/cparser/Cleanup.ml +++ b/cparser/Cleanup.ml @@ -131,9 +131,9 @@ let visible_decl (sto, id, ty, init) = let visible_fundef f = match f.fd_storage with - | Storage_default -> not f.fd_inline - | Storage_extern -> true - | Storage_static -> false + | Storage_default | Storage_thread_local -> not f.fd_inline + | Storage_extern | Storage_thread_local_extern -> true + | Storage_static | Storage_thread_local_static -> false | Storage_auto | Storage_register -> assert false let rec add_init_globdecls accu = function diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml index 9aeec421..78970990 100644 --- a/cparser/Cprint.ml +++ b/cparser/Cprint.ml @@ -361,6 +361,9 @@ let storage pp = function | Storage_default -> () | Storage_extern -> fprintf pp "extern " | Storage_static -> fprintf pp "static " + | Storage_thread_local -> fprintf pp "_Thread_local" + | Storage_thread_local_extern -> fprintf pp "extern _Thread_local" + | Storage_thread_local_static -> fprintf pp "static _Thread_local" | Storage_auto -> () (* used only in blocks, where it can be omitted *) | Storage_register -> fprintf pp "register " diff --git a/cparser/Elab.ml b/cparser/Elab.ml index b76a61cb..98f88dc9 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -152,6 +152,9 @@ let name_of_storage_class = function | Storage_default -> "" | Storage_extern -> "'extern'" | Storage_static -> "'static'" + | Storage_thread_local -> "'_Thread_local'" + | Storage_thread_local_extern -> "'_Thread_local extern'" + | Storage_thread_local_static -> "'_Thread_local static'" | Storage_auto -> "'auto'" | Storage_register -> "'register'" @@ -177,15 +180,29 @@ let combine_toplevel_definitions loc env s old_sto old_ty sto ty = | Storage_static,Storage_static | Storage_extern,Storage_extern | Storage_default,Storage_default -> sto - | _,Storage_static -> + | Storage_thread_local_static,Storage_thread_local_static + | Storage_thread_local_extern,Storage_thread_local_extern + | Storage_thread_local,Storage_thread_local -> sto + | _,Storage_static | _,Storage_thread_local_static -> error loc "static declaration of '%s' follows non-static declaration" s; sto | Storage_static,_ -> Storage_static (* Static stays static *) - | Storage_extern,_ -> if is_function_type env new_ty then Storage_extern else sto + | Storage_thread_local_static,_ -> Storage_thread_local_static (* Thread-local static stays static *) + | (Storage_extern|Storage_thread_local_extern),_ -> if is_function_type env new_ty then Storage_extern else sto | Storage_default,Storage_extern -> if is_global_defined s && is_function_type env ty then warning loc Extern_after_definition "this extern declaration follows a non-extern definition and is ignored"; Storage_extern + | Storage_thread_local,Storage_thread_local_extern -> + if is_global_defined s && is_function_type env ty then + warning loc Extern_after_definition "this extern declaration follows a non-extern definition and is ignored"; + Storage_extern + | Storage_thread_local, Storage_default -> + error loc "Non thread-local declaration follows thread-local"; + sto + | Storage_default, (Storage_thread_local|Storage_thread_local_extern) -> + error loc "Thread-local declaration follows non thread-local"; + sto | _,Storage_extern -> old_sto (* "auto" and "register" don't appear in toplevel definitions. Normally this was checked earlier. Generate error message -- cgit From 9d4d852eb960926453f216722f629d3c8dc9cf13 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 16:01:35 +0100 Subject: actually process the modifiers --- cparser/Elab.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 98f88dc9..a428d17c 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -643,7 +643,6 @@ let rec elab_specifier ?(only = false) loc env specifier = - a set of attributes (const, volatile, restrict) - a list of type specifiers *) let sto = ref Storage_default - and thread_local = ref false and inline = ref false and noreturn = ref false and restrict = ref false @@ -663,7 +662,18 @@ let rec elab_specifier ?(only = false) loc env specifier = | STATIC -> sto := Storage_static | EXTERN -> sto := Storage_extern | REGISTER -> sto := Storage_register - | THREAD_LOCAL -> thread_local := true + | THREAD_LOCAL -> + sto := (match !sto with + | Storage_static | Storage_thread_local_static -> + Storage_thread_local_static + | Storage_extern | Storage_thread_local_extern -> + Storage_thread_local_extern + | Storage_default | Storage_thread_local -> + Storage_thread_local + | Storage_auto|Storage_register -> + error loc "_Thread_local on auto or register variable"; + !sto + ) | TYPEDEF -> if !typedef then error loc "multiple uses of 'typedef'"; -- cgit From 26d2601818c387a540a7d89aec1363981f601b7e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 16:16:51 +0100 Subject: seems to process _Thread_local but not till backend --- cfrontend/C2C.ml | 21 ++++++++++++++------- cparser/Cleanup.ml | 2 +- cparser/Elab.ml | 1 + cparser/Rename.ml | 7 +++++-- test/monniaux/thread_local/thread_local.c | 1 + 5 files changed, 22 insertions(+), 10 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 24e3cacf..015a2eb6 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -45,13 +45,17 @@ let decl_atom : (AST.ident, atom_info) Hashtbl.t = Hashtbl.create 103 let atom_is_static a = try - (Hashtbl.find decl_atom a).a_storage = C.Storage_static + match (Hashtbl.find decl_atom a).a_storage with + | C.Storage_static | C.Storage_thread_local_static -> true + | _ -> false with Not_found -> false let atom_is_extern a = try - (Hashtbl.find decl_atom a).a_storage = C.Storage_extern + match (Hashtbl.find decl_atom a).a_storage with + | C.Storage_extern| C.Storage_thread_local_extern -> true + | _ -> false with Not_found -> false @@ -1226,7 +1230,8 @@ let convertFundef loc env fd = let vars = List.map (fun (sto, id, ty, init) -> - if sto = Storage_extern || sto = Storage_static then + if sto = Storage_extern || sto = Storage_thread_local_extern + || sto = Storage_static || sto = Storage_thread_local_static then unsupported "'static' or 'extern' local variable"; if init <> None then unsupported "initialized local variable"; @@ -1328,7 +1333,8 @@ let convertGlobvar loc env (sto, id, ty, optinit) = let init' = match optinit with | None -> - if sto = C.Storage_extern then [] else [AST.Init_space sz] + if sto = C.Storage_extern || sto = C.Storage_thread_local_extern + then [] else [AST.Init_space sz] | Some i -> convertInitializer env ty i in let (section, access) = @@ -1336,7 +1342,8 @@ let convertGlobvar loc env (sto, id, ty, optinit) = if Z.gt sz (Z.of_uint64 0xFFFF_FFFFL) then error "'%s' is too big (%s bytes)" id.name (Z.to_string sz); - if sto <> C.Storage_extern && Cutil.incomplete_type env ty then + if sto <> C.Storage_extern && sto <> C.Storage_thread_local_extern + && Cutil.incomplete_type env ty then error "'%s' has incomplete type" id.name; Hashtbl.add decl_atom id' { a_storage = sto; @@ -1434,7 +1441,7 @@ let cleanupGlobals p = if IdentSet.mem fd.fd_name !strong then error "multiple definitions of %s" fd.fd_name.name; strong := IdentSet.add fd.fd_name !strong - | C.Gdecl(Storage_extern, id, ty, init) -> + | C.Gdecl((Storage_extern|Storage_thread_local_extern), id, ty, init) -> extern := IdentSet.add id !extern | C.Gdecl(sto, id, ty, Some i) -> if IdentSet.mem id !strong then @@ -1453,7 +1460,7 @@ let cleanupGlobals p = match g.gdesc with | C.Gdecl(sto, id, ty, init) -> let better_def_exists = - if sto = Storage_extern then + if sto = Storage_extern || sto = Storage_thread_local_extern then IdentSet.mem id !strong || IdentSet.mem id !weak else if init = None then IdentSet.mem id !strong diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml index b15e150c..9f19395a 100644 --- a/cparser/Cleanup.ml +++ b/cparser/Cleanup.ml @@ -126,7 +126,7 @@ let add_enum e = *) let visible_decl (sto, id, ty, init) = - sto = Storage_default && + (sto = Storage_default || sto = Storage_thread_local) && match ty with TFun _ -> false | _ -> true let visible_fundef f = diff --git a/cparser/Elab.ml b/cparser/Elab.ml index a428d17c..42505a2c 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -674,6 +674,7 @@ let rec elab_specifier ?(only = false) loc env specifier = error loc "_Thread_local on auto or register variable"; !sto ) + | TYPEDEF -> if !typedef then error loc "multiple uses of 'typedef'"; diff --git a/cparser/Rename.ml b/cparser/Rename.ml index 64412194..aeeb9326 100644 --- a/cparser/Rename.ml +++ b/cparser/Rename.ml @@ -257,13 +257,16 @@ let rec reserve_public env = function match dcl.gdesc with | Gdecl(sto, id, _, _) -> begin match sto with - | Storage_default | Storage_extern -> enter_public env id + | Storage_default | Storage_thread_local + | Storage_extern | Storage_thread_local_extern -> + enter_public env id | Storage_static -> env | _ -> assert false end | Gfundef f -> begin match f.fd_storage with - | Storage_default | Storage_extern -> enter_public env f.fd_name + | Storage_default | Storage_extern + -> enter_public env f.fd_name | Storage_static -> env | _ -> assert false end diff --git a/test/monniaux/thread_local/thread_local.c b/test/monniaux/thread_local/thread_local.c index 0c50f216..48f9d99a 100644 --- a/test/monniaux/thread_local/thread_local.c +++ b/test/monniaux/thread_local/thread_local.c @@ -1 +1,2 @@ _Thread_local int toto; +int toto2; -- cgit From f64f6374c4b9db9f1111f272d842a625f0507ae6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 16:33:06 +0100 Subject: it now works, no more ugly hack to access thread local data --- cfrontend/C2C.ml | 9 +++++++++ cparser/Elab.ml | 2 +- mppa_k1c/TargetPrinter.ml | 12 ++++++++---- runtime/include/ccomp_k1c_fixes.h | 2 +- test/monniaux/thread_local/thread_local.c | 4 ++++ 5 files changed, 23 insertions(+), 6 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 015a2eb6..d03392b1 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -59,6 +59,15 @@ let atom_is_extern a = with Not_found -> false +let atom_is_thread_local a = + try + match (Hashtbl.find decl_atom a).a_storage with + | C.Storage_thread_local_extern| C.Storage_thread_local_static + | C.Storage_thread_local -> true + | _ -> false + with Not_found -> + false + let atom_alignof a = try (Hashtbl.find decl_atom a).a_alignment diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 42505a2c..3c754dd6 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -655,7 +655,7 @@ let rec elab_specifier ?(only = false) loc env specifier = restrict := cv = CV_RESTRICT; attr := add_attributes (elab_cvspec env cv) !attr | SpecStorage st -> - if !sto <> Storage_default && st <> TYPEDEF then + if !sto <> Storage_default && st <> TYPEDEF && st <> THREAD_LOCAL then error loc "multiple storage classes in declaration specifier"; begin match st with | AUTO -> sto := Storage_auto diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 930b1c51..886b58d3 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -211,13 +211,17 @@ module Target (*: TARGET*) = (* Generate code to load the address of id + ofs in register r *) -(* FIXME DMonniaux ugly ugly hack to get at standard __thread data *) let loadsymbol oc r id ofs = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); - fprintf oc " make %a = %s\n" ireg r (extern_atom id) - end else begin - if (extern_atom id) = "_impure_thread_data" then begin + if C2C.atom_is_thread_local id then begin + fprintf oc " addd %a = $r13, @tprel(%s)\n" ireg r (extern_atom id) + end else begin + fprintf oc " make %a = %s\n" ireg r (extern_atom id) + end + end else + begin + if C2C.atom_is_thread_local id then begin fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) end else begin fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) diff --git a/runtime/include/ccomp_k1c_fixes.h b/runtime/include/ccomp_k1c_fixes.h index 718ac3e5..69097d06 100644 --- a/runtime/include/ccomp_k1c_fixes.h +++ b/runtime/include/ccomp_k1c_fixes.h @@ -6,7 +6,7 @@ #endif #undef __GNUC__ -#define __thread +#define __thread _Thread_local struct __int128_ccomp { long __int128_ccomp_low; long __int128_ccomp_high; }; diff --git a/test/monniaux/thread_local/thread_local.c b/test/monniaux/thread_local/thread_local.c index 48f9d99a..824c8543 100644 --- a/test/monniaux/thread_local/thread_local.c +++ b/test/monniaux/thread_local/thread_local.c @@ -1,2 +1,6 @@ _Thread_local int toto; int toto2; + +int foobar(void) { + return toto; +} -- cgit From 3609ee93e39f4896d749640760f82abdcde33fed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 18:06:23 +0100 Subject: thread local declarations now work --- backend/PrintAsm.ml | 2 +- backend/PrintAsmaux.ml | 1 + cfrontend/C2C.ml | 6 +++++- common/Sections.ml | 21 ++++++++++++++------- common/Sections.mli | 5 +++-- mppa_k1c/TargetPrinter.ml | 8 ++++++-- test/monniaux/thread_local/thread_local.c | 9 ++++++++- 7 files changed, 38 insertions(+), 14 deletions(-) diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml index 155f5e55..0635e32d 100644 --- a/backend/PrintAsm.ml +++ b/backend/PrintAsm.ml @@ -121,7 +121,7 @@ module Printer(Target:TARGET) = let sec = match C2C.atom_sections name with | [s] -> s - | _ -> Section_data true + | _ -> Section_data (true, false) and align = match C2C.atom_alignof name with | Some a -> a diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 8652b2c5..756e6c93 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -303,6 +303,7 @@ let print_version_and_options oc comment = fprintf oc " %s" Commandline.argv.(i) done; fprintf oc "\n" + (** Get the name of the common section if it is used otherwise the given section name, with bss as default *) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index d03392b1..441c0a14 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1347,7 +1347,11 @@ let convertGlobvar loc env (sto, id, ty, optinit) = | Some i -> convertInitializer env ty i in let (section, access) = - Sections.for_variable env id' ty (optinit <> None) in + Sections.for_variable env id' ty (optinit <> None) + (match sto with + | Storage_thread_local | Storage_thread_local_extern + | Storage_thread_local_static -> true + | _ -> false) in if Z.gt sz (Z.of_uint64 0xFFFF_FFFFL) then error "'%s' is too big (%s bytes)" id.name (Z.to_string sz); diff --git a/common/Sections.ml b/common/Sections.ml index 30be9e69..9555c203 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -17,7 +17,8 @@ type section_name = | Section_text - | Section_data of bool (* true = init data, false = uninit data *) + | Section_data of bool (* true = init data, false = uninit data *) + * bool (* thread local? *) | Section_small_data of bool | Section_const of bool | Section_small_const of bool @@ -47,8 +48,8 @@ type section_info = { } let default_section_info = { - sec_name_init = Section_data true; - sec_name_uninit = Section_data false; + sec_name_init = Section_data (true, false); + sec_name_uninit = Section_data (false, false); sec_writable = true; sec_executable = false; sec_access = Access_default @@ -63,8 +64,13 @@ let builtin_sections = [ sec_writable = false; sec_executable = true; sec_access = Access_default}; "DATA", - {sec_name_init = Section_data true; - sec_name_uninit = Section_data false; + {sec_name_init = Section_data (true, false); + sec_name_uninit = Section_data (false, false); + sec_writable = true; sec_executable = false; + sec_access = Access_default}; + "TDATA", + {sec_name_init = Section_data (true, true); + sec_name_uninit = Section_data (false, true); sec_writable = true; sec_executable = false; sec_access = Access_default}; "SDATA", @@ -162,7 +168,7 @@ let gcc_section name readonly exec = (* Determine section for a variable definition *) -let for_variable env id ty init = +let for_variable env id ty init thrl = let attr = Cutil.attributes_of_type env ty in let readonly = List.mem C.AConst attr && not(List.mem C.AVolatile attr) in let si = @@ -181,7 +187,8 @@ let for_variable env id ty init = let name = if readonly then if size <= !Clflags.option_small_const then "SCONST" else "CONST" - else if size <= !Clflags.option_small_data then "SDATA" else "DATA" in + else if size <= !Clflags.option_small_data then "SDATA" else + if thrl then "TDATA" else "DATA" in try Hashtbl.find current_section_table name with Not_found -> diff --git a/common/Sections.mli b/common/Sections.mli index bc97814d..e882f042 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -18,7 +18,8 @@ type section_name = | Section_text - | Section_data of bool (* true = init data, false = uninit data *) + | Section_data of bool (* true = init data, false = uninit data *) + * bool (* thread local? *) | Section_small_data of bool | Section_const of bool | Section_small_const of bool @@ -46,7 +47,7 @@ val define_section: -> ?writable:bool -> ?executable:bool -> ?access:access_mode -> unit -> unit val use_section_for: AST.ident -> string -> bool -val for_variable: Env.t -> AST.ident -> C.typ -> bool -> +val for_variable: Env.t -> AST.ident -> C.typ -> bool -> bool -> section_name * access_mode val for_function: Env.t -> AST.ident -> C.attributes -> section_name list val for_stringlit: unit -> section_name diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 886b58d3..ca1d3229 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -157,8 +157,12 @@ module Target (*: TARGET*) = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> - if i then ".data" else "COMM" + | Section_data(true, true) -> + ".section .tdata,\"awT\",@progbits" + | Section_data(false, true) -> + ".section .tbss,\"awT\",@nobits" + | Section_data(i, false) | Section_small_data(i) -> + (if i then ".data" else "COMM") | Section_const i | Section_small_const i -> if i then ".section .rodata" else "COMM" | Section_string -> ".section .rodata" diff --git a/test/monniaux/thread_local/thread_local.c b/test/monniaux/thread_local/thread_local.c index 824c8543..7a50db0a 100644 --- a/test/monniaux/thread_local/thread_local.c +++ b/test/monniaux/thread_local/thread_local.c @@ -1,6 +1,13 @@ +#include + _Thread_local int toto; -int toto2; +_Thread_local int toto2 = 45; int foobar(void) { return toto; } + +int main() { + printf("%d %d\n", toto, toto2); + return 0; +} -- cgit From f69ba5f0bb0ee5e2b08f57290bee9635dd13f33c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 18:23:38 +0100 Subject: fix for x86+arm unsupported thread local --- arm/TargetPrinter.ml | 4 +++- x86/TargetPrinter.ml | 12 +++++++++--- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 03e06a65..517ae0a8 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -147,7 +147,9 @@ struct let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data(i, false) -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 6159437e..e371380c 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -133,7 +133,9 @@ module ELF_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data i -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" @@ -191,7 +193,9 @@ module MacOS_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data i -> if i || (not !Clflags.option_fcommon) then ".data" else "COMM" | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".const" else "COMM" @@ -268,7 +272,9 @@ module Cygwin_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data i -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM" -- cgit From 424df9761ae4f3c9ce91ba785aef111bedd9125a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 24 Feb 2020 19:49:56 +0100 Subject: fixes for aarch64 arm ppc ppc64 --- aarch64/TargetPrinter.ml | 4 +++- arm/TargetPrinter.ml | 2 +- backend/JsonAST.ml | 2 +- powerpc/TargetPrinter.ml | 8 ++++++-- riscV/TargetPrinter.ml | 4 +++- 5 files changed, 14 insertions(+), 6 deletions(-) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index e54673dd..e7edcf0d 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -133,7 +133,9 @@ module Target : TARGET = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data i -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 517ae0a8..54af7cd5 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -149,7 +149,7 @@ struct | Section_text -> ".text" | Section_data(i, true) -> failwith "_Thread_local unsupported on this platform" - | Section_data(i, false) | Section_small_data(i, false) -> + | Section_data(i, false) | Section_small_data(i) -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" diff --git a/backend/JsonAST.ml b/backend/JsonAST.ml index 8905e252..c73bf30d 100644 --- a/backend/JsonAST.ml +++ b/backend/JsonAST.ml @@ -31,7 +31,7 @@ let pp_section pp sec = pp_jobject_end pp in match sec with | Section_text -> pp_simple "Text" - | Section_data init -> pp_complex "Data" init + | Section_data(init, thread_local) -> pp_complex "Data" init (* FIXME *) | Section_small_data init -> pp_complex "Small Data" init | Section_const init -> pp_complex "Const" init | Section_small_const init -> pp_complex "Small Const" init diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml index 0f608d25..3ea03786 100644 --- a/powerpc/TargetPrinter.ml +++ b/powerpc/TargetPrinter.ml @@ -117,7 +117,9 @@ module Linux_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) -> if i then ".data" else @@ -218,7 +220,9 @@ module Diab_System : SYSTEM = let name_of_section = function | Section_text -> ".text" - | Section_data i -> if i then ".data" else common_section () + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data (i, false) -> if i then ".data" else common_section () | Section_small_data i -> if i then ".sdata" else ".sbss" | Section_const _ -> ".text" | Section_small_const _ -> ".sdata2" diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml index 64bcea4c..1f02ca71 100644 --- a/riscV/TargetPrinter.ml +++ b/riscV/TargetPrinter.ml @@ -107,7 +107,9 @@ module Target : TARGET = let name_of_section = function | Section_text -> ".text" - | Section_data i | Section_small_data i -> + | Section_data(i, true) -> + failwith "_Thread_local unsupported on this platform" + | Section_data(i, false) | Section_small_data i -> if i then ".data" else common_section () | Section_const i | Section_small_const i -> if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM" -- cgit From 834f4bacec710dd841fcdc1945210cf3fb6cef70 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Tue, 25 Feb 2020 10:31:19 +0100 Subject: Only one job for hardcheck.sh and hardtest.sh --- test/mppa/hardcheck.sh | 2 +- test/mppa/hardtest.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/mppa/hardcheck.sh b/test/mppa/hardcheck.sh index 82b63182..b6538f0e 100755 --- a/test/mppa/hardcheck.sh +++ b/test/mppa/hardcheck.sh @@ -3,4 +3,4 @@ source do_test.sh -do_test hardcheck +do_test hardcheck 1 diff --git a/test/mppa/hardtest.sh b/test/mppa/hardtest.sh index 09511da6..6321bc7d 100755 --- a/test/mppa/hardtest.sh +++ b/test/mppa/hardtest.sh @@ -3,4 +3,4 @@ source do_test.sh -do_test hardtest +do_test hardtest 1 -- cgit From 84a198eddcc2a8cb825e144c9e97642aa45fed7c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 16:17:52 +0100 Subject: move lattice stuff where it belongs --- lib/HashedSet.v | 1270 ++++++++++++++++++++++++++++++++++++++++++++++++++ lib/HashedSetaux.ml | 55 +++ lib/HashedSetaux.mli | 6 + lib/Lattice.v | 115 +++++ 4 files changed, 1446 insertions(+) create mode 100644 lib/HashedSet.v create mode 100644 lib/HashedSetaux.ml create mode 100644 lib/HashedSetaux.mli diff --git a/lib/HashedSet.v b/lib/HashedSet.v new file mode 100644 index 00000000..bf781a49 --- /dev/null +++ b/lib/HashedSet.v @@ -0,0 +1,1270 @@ +Require Import ZArith. +Require Import Bool. +Require Import List. +Require Coq.Logic.Eqdep_dec. + + (* begin from Maps *) + Fixpoint prev_append (i j: positive) {struct i} : positive := + match i with + | xH => j + | xI i' => prev_append i' (xI j) + | xO i' => prev_append i' (xO j) + end. + + Definition prev (i: positive) : positive := + prev_append i xH. + + Lemma prev_append_prev i j: + prev (prev_append i j) = prev_append j i. + Proof. + revert j. unfold prev. + induction i as [i IH|i IH|]. 3: reflexivity. + intros j. simpl. rewrite IH. reflexivity. + intros j. simpl. rewrite IH. reflexivity. + Qed. + + Lemma prev_involutive i : + prev (prev i) = i. + Proof (prev_append_prev i xH). + + Lemma prev_append_inj i j j' : + prev_append i j = prev_append i j' -> j = j'. + Proof. + revert j j'. + induction i as [i Hi|i Hi|]; intros j j' H; auto; + specialize (Hi _ _ H); congruence. + Qed. + + (* end from Maps *) + +Lemma orb_idem: forall b, orb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_idem: forall b, andb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_negb_false: forall b, andb b (negb b) = false. +Proof. + destruct b; reflexivity. +Qed. + +Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false: pset. + +Module WR. +Inductive pset : Type := +| Empty : pset +| Node : pset -> bool -> pset -> pset. + +Definition empty := Empty. + +Definition is_empty x := + match x with + | Empty => true + | Node _ _ _ => false + end. + +Fixpoint wf x := + match x with + | Empty => true + | Node b0 f b1 => + (wf b0) && (wf b1) && + ((negb (is_empty b0)) || f || (negb (is_empty b1))) + end. + +Definition iswf x := (wf x)=true. + +Lemma empty_wf : iswf empty. +Proof. + reflexivity. +Qed. + +Definition pset_eq : + forall s s': pset, { s=s' } + { s <> s' }. +Proof. + induction s; destruct s'; repeat decide equality. +Qed. + +Fixpoint contains (s : pset) (i : positive) {struct i} : bool := + match s with + | Empty => false + | Node b0 f b1 => + match i with + | xH => f + | xO ii => contains b0 ii + | xI ii => contains b1 ii + end + end. + +Lemma gempty : + forall i : positive, + contains Empty i = false. +Proof. + destruct i; simpl; reflexivity. +Qed. + +Hint Resolve gempty : pset. +Hint Rewrite gempty : pset. + +Definition node (b0 : pset) (f : bool) (b1 : pset) : pset := + match b0, f, b1 with + | Empty, false, Empty => Empty + | _, _, _ => Node b0 f b1 + end. + +Lemma wf_node : + forall b0 f b1, + iswf b0 -> iswf b1 -> iswf (node b0 f b1). +Proof. + destruct b0; destruct f; destruct b1; simpl. + all: unfold iswf; simpl; intros; trivial. + all: autorewrite with pset; trivial. + all: rewrite H. + all: rewrite H0. + all: reflexivity. +Qed. + +Hint Resolve wf_node: pset. + +Lemma gnode : + forall b0 f b1 i, + contains (node b0 f b1) i = + contains (Node b0 f b1) i. +Proof. + destruct b0; simpl; trivial. + destruct f; simpl; trivial. + destruct b1; simpl; trivial. + intro. + rewrite gempty. + destruct i; simpl; trivial. + all: symmetry; apply gempty. +Qed. + +Hint Rewrite gnode : pset. + +Fixpoint add (i : positive) (s : pset) {struct i} : pset := + match s with + | Empty => + match i with + | xH => Node Empty true Empty + | xO ii => Node (add ii Empty) false Empty + | xI ii => Node Empty false (add ii Empty) + end + | Node b0 f b1 => + match i with + | xH => Node b0 true b1 + | xO ii => Node (add ii b0) f b1 + | xI ii => Node b0 f (add ii b1) + end + end. + +Lemma add_nonempty: + forall i s, is_empty (add i s) = false. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Hint Rewrite add_nonempty : pset. +Hint Resolve add_nonempty : pset. + +Lemma wf_add: + forall i s, (iswf s) -> (iswf (add i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: autorewrite with pset; simpl; trivial. + 1,3: auto with pset. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: intuition. +Qed. + +Hint Resolve wf_add : pset. + +Theorem gadds : + forall i : positive, + forall s : pset, + contains (add i s) i = true. +Proof. + induction i; destruct s; simpl; auto. +Qed. + +Hint Resolve gadds : pset. +Hint Rewrite gadds : pset. + +Theorem gaddo : + forall i j : positive, + forall s : pset, + i <> j -> + contains (add i s) j = contains s j. +Proof. + induction i; destruct j; destruct s; simpl; intro; auto with pset. + 5, 6: congruence. + all: rewrite IHi by congruence. + all: trivial. + all: apply gempty. +Qed. + +Hint Resolve gaddo : pset. + +Fixpoint remove (i : positive) (s : pset) { struct i } : pset := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 false b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => node (remove ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 f (remove ii b1) + end + end. + +Lemma wf_remove : + forall i s, (iswf s) -> (iswf (remove i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: apply wf_node. + all: intuition. + all: apply IHi. + all: assumption. +Qed. + + +Fixpoint remove_noncanon (i : positive) (s : pset) { struct i } : pset := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 false b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node (remove_noncanon ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 f (remove_noncanon ii b1) + end + end. + +Lemma remove_noncanon_same: + forall i j s, (contains (remove i s) j) = (contains (remove_noncanon i s) j). +Proof. + induction i; destruct s; simpl; trivial. + all: rewrite gnode. + 3: reflexivity. + all: destruct j; simpl; trivial. +Qed. + +Lemma remove_empty : + forall i, remove i Empty = Empty. +Proof. + induction i; simpl; trivial. +Qed. + +Hint Rewrite remove_empty : pset. +Hint Resolve remove_empty : pset. + +Lemma gremove_noncanon_s : + forall i : positive, + forall s : pset, + contains (remove_noncanon i s) i = false. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Theorem gremoves : + forall i : positive, + forall s : pset, + contains (remove i s) i = false. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_s. +Qed. + +Hint Resolve gremoves : pset. +Hint Rewrite gremoves : pset. + +Lemma gremove_noncanon_o : + forall i j : positive, + forall s : pset, + i<>j -> + contains (remove_noncanon i s) j = contains s j. +Proof. + induction i; destruct j; destruct s; simpl; intro; trivial. + 1, 2: rewrite IHi by congruence. + 1, 2: reflexivity. + congruence. +Qed. + +Theorem gremoveo : + forall i j : positive, + forall s : pset, + i<>j -> + contains (remove i s) j = contains s j. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_o. + assumption. +Qed. + +Hint Resolve gremoveo : pset. + +Fixpoint union_nonopt (s s' : pset) : pset := + match s, s' with + | Empty, _ => s' + | _, Empty => s + | (Node b0 f b1), (Node b0' f' b1') => + Node (union_nonopt b0 b0') (orb f f') (union_nonopt b1 b1') + end. + +Theorem gunion_nonopt: + forall s s' : pset, + forall j : positive, + (contains (union_nonopt s s')) j = orb (contains s j) (contains s' j). +Proof. + induction s; destruct s'; intro; simpl; autorewrite with pset; simpl; trivial. + destruct j; simpl; trivial. +Qed. + + +Fixpoint union (s s' : pset) : pset := + if pset_eq s s' then s else + match s, s' with + | Empty, _ => s' + | _, Empty => s + | (Node b0 f b1), (Node b0' f' b1') => + Node (union b0 b0') (orb f f') (union b1 b1') + end. + +Lemma union_nonempty1: + forall s s', + (is_empty s) = false -> is_empty (union s s')= false. +Proof. + induction s; destruct s'; simpl; try discriminate. + all: destruct pset_eq; simpl; trivial. +Qed. + +Lemma union_nonempty2: + forall s s', + (is_empty s') = false -> is_empty (union s s')= false. +Proof. + induction s; destruct s'; simpl; try discriminate. + all: destruct pset_eq; simpl; trivial; discriminate. +Qed. + +Hint Resolve union_nonempty1 union_nonempty2 : pset. + +Lemma wf_union : + forall s s', (iswf s) -> (iswf s') -> (iswf (union s s')). +Proof. + induction s; destruct s'; intros; simpl. + all: destruct pset_eq; trivial. + unfold iswf in *. simpl in *. + repeat rewrite andb_true_iff in H. + repeat rewrite andb_true_iff in H0. + rewrite IHs1. + rewrite IHs2. + simpl. + all: intuition. + repeat rewrite orb_true_iff in H2, H3. + repeat rewrite negb_true_iff in H2, H3. + repeat rewrite orb_true_iff. + repeat rewrite negb_true_iff. + intuition auto with pset. +Qed. + +Hint Resolve wf_union : pset. + +Theorem gunion: + forall s s' : pset, + forall j : positive, + (contains (union s s')) j = orb (contains s j) (contains s' j). +Proof. + induction s; destruct s'; intro; simpl. + all: destruct pset_eq as [EQ | NEQ]; try congruence. + all: autorewrite with pset; simpl; trivial. + - rewrite <- EQ. + symmetry. + apply orb_idem. + - destruct j; simpl; trivial. +Qed. + +Fixpoint inter_noncanon (s s' : pset) : pset := + if pset_eq s s' then s else + match s, s' with + | Empty, _ | _, Empty => Empty + | (Node b0 f b1), (Node b0' f' b1') => + Node (inter_noncanon b0 b0') (andb f f') (inter_noncanon b1 b1') + end. + +Lemma ginter_noncanon: + forall s s' : pset, + forall j : positive, + (contains (inter_noncanon s s')) j = andb (contains s j) (contains s' j). +Proof. + induction s; destruct s'; intro; simpl. + all: destruct pset_eq as [EQ | NEQ]; try congruence. + all: autorewrite with pset; simpl; trivial. + - rewrite <- EQ. + symmetry. + apply andb_idem. + - destruct j; simpl; trivial. +Qed. + +Fixpoint inter (s s' : pset) : pset := + if pset_eq s s' then s else + match s, s' with + | Empty, _ | _, Empty => Empty + | (Node b0 f b1), (Node b0' f' b1') => + node (inter b0 b0') (andb f f') (inter b1 b1') + end. + +Lemma wf_inter : + forall s s', (iswf s) -> (iswf s') -> (iswf (inter s s')). +Proof. + induction s; destruct s'; intros; simpl. + all: destruct pset_eq; trivial. + unfold iswf in H, H0. + simpl in H, H0. + repeat rewrite andb_true_iff in H. + repeat rewrite andb_true_iff in H0. + fold (iswf s1) in *. + fold (iswf s2) in *. + intuition. +Qed. + +Hint Resolve wf_inter : pset. + +Lemma inter_noncanon_same: + forall s s' j, (contains (inter s s') j) = (contains (inter_noncanon s s') j). +Proof. + induction s; destruct s'; simpl; trivial. + destruct pset_eq; trivial. + destruct j; rewrite gnode; simpl; auto. +Qed. + +Theorem ginter: + forall s s' : pset, + forall j : positive, + (contains (inter s s')) j = andb (contains s j) (contains s' j). +Proof. + intros. + rewrite inter_noncanon_same. + apply ginter_noncanon. +Qed. + +Hint Resolve ginter gunion : pset. +Hint Rewrite ginter gunion : pset. + +Fixpoint subtract_noncanon (s s' : pset) : pset := + if pset_eq s s' then Empty else + match s, s' with + | Empty, _ => Empty + | _, Empty => s + | (Node b0 f b1), (Node b0' f' b1') => + Node (subtract_noncanon b0 b0') (andb f (negb f')) (subtract_noncanon b1 b1') + end. + +Lemma gsubtract_noncanon: + forall s s' : pset, + forall j : positive, + (contains (subtract_noncanon s s')) j = andb (contains s j) (negb (contains s' j)). +Proof. + induction s; destruct s'; intro; simpl. + all: destruct pset_eq as [EQ | NEQ]; try congruence. + all: autorewrite with pset; simpl; trivial. + - rewrite <- EQ. + symmetry. + apply andb_negb_false. + - destruct j; simpl; trivial. +Qed. + +Fixpoint subtract (s s' : pset) : pset := + if pset_eq s s' then Empty else + match s, s' with + | Empty, _ => Empty + | _, Empty => s + | (Node b0 f b1), (Node b0' f' b1') => + node (subtract b0 b0') (andb f (negb f')) (subtract b1 b1') + end. + +Lemma wf_subtract : + forall s s', (iswf s) -> (iswf s') -> (iswf (subtract s s')). +Proof. + induction s; destruct s'; intros; simpl. + all: destruct pset_eq; trivial. + reflexivity. + + unfold iswf in H, H0. + simpl in H, H0. + + repeat rewrite andb_true_iff in H. + repeat rewrite andb_true_iff in H0. + fold (iswf s1) in *. + fold (iswf s2) in *. + intuition. +Qed. + +Hint Resolve wf_subtract : pset. + +Lemma subtract_noncanon_same: + forall s s' j, (contains (subtract s s') j) = (contains (subtract_noncanon s s') j). +Proof. + induction s; destruct s'; simpl; trivial. + destruct pset_eq; trivial. + destruct j; rewrite gnode; simpl; auto. +Qed. + +Theorem gsubtract: + forall s s' : pset, + forall j : positive, + (contains (subtract s s')) j = andb (contains s j) (negb (contains s' j)). +Proof. + intros. + rewrite subtract_noncanon_same. + apply gsubtract_noncanon. +Qed. + +Hint Resolve gsubtract : pset. +Hint Rewrite gsubtract : pset. + +Lemma wf_is_nonempty : + forall s, iswf s -> is_empty s = false -> exists i, contains s i = true. +Proof. + induction s; simpl; trivial. + discriminate. + intro WF. + unfold iswf in WF. + simpl in WF. + repeat rewrite andb_true_iff in WF. + repeat rewrite orb_true_iff in WF. + repeat rewrite negb_true_iff in WF. + fold (iswf s1) in WF. + fold (iswf s2) in WF. + intuition. + - destruct H5 as [i K]. + exists (xO i). + simpl. + assumption. + - exists xH. + simpl. + assumption. + - destruct H5 as [i K]. + exists (xI i). + simpl. + assumption. +Qed. + +Hint Resolve wf_is_nonempty : pset. + +Lemma wf_is_empty1 : + forall s, iswf s -> (forall i, (contains s i) = false) -> is_empty s = true. +Proof. + induction s; trivial. + intro WF. + unfold iswf in WF. + simpl in WF. + repeat rewrite andb_true_iff in WF. + fold (iswf s1) in WF. + fold (iswf s2) in WF. + intro ALL. + intuition. + exfalso. + repeat rewrite orb_true_iff in H0. + repeat rewrite negb_true_iff in H0. + intuition. + - rewrite H in H0. discriminate. + intro i. + specialize ALL with (xO i). + simpl in ALL. + assumption. + - specialize ALL with xH. + simpl in ALL. + congruence. + - rewrite H3 in H4. discriminate. + intro i. + specialize ALL with (xI i). + simpl in ALL. + assumption. +Qed. + +Hint Resolve wf_is_empty1 : pset. + +Lemma wf_eq : + forall s s', iswf s -> iswf s' -> s <> s' -> + exists i, (contains s i) <> (contains s' i). +Proof. + induction s; destruct s'; intros WF WF' DIFF; simpl. + - congruence. + - assert (exists i, (contains (Node s'1 b s'2) i)= true) as K by auto with pset. + destruct K as [i Z]. + exists i. + rewrite Z. + rewrite gempty. + discriminate. + - assert (exists i, (contains (Node s1 b s2) i)= true) as K by auto with pset. + destruct K as [i Z]. + exists i. + rewrite Z. + rewrite gempty. + discriminate. + - destruct (pset_eq s1 s'1). + + subst s'1. + destruct (pset_eq s2 s'2). + * subst s'2. + exists xH. + simpl. + congruence. + * specialize IHs2 with s'2. + unfold iswf in WF. + simpl in WF. + repeat rewrite andb_true_iff in WF. + fold (iswf s1) in WF. + fold (iswf s2) in WF. + unfold iswf in WF'. + simpl in WF'. + repeat rewrite andb_true_iff in WF'. + fold (iswf s'2) in WF'. + intuition. + destruct H1 as [i K]. + exists (xI i). + simpl. + assumption. + + specialize IHs1 with s'1. + unfold iswf in WF. + simpl in WF. + repeat rewrite andb_true_iff in WF. + fold (iswf s1) in WF. + fold (iswf s2) in WF. + unfold iswf in WF'. + simpl in WF'. + repeat rewrite andb_true_iff in WF'. + fold (iswf s'1) in WF'. + fold (iswf s'2) in WF'. + intuition. + destruct H1 as [i K]. + exists (xO i). + simpl. + assumption. +Qed. + +Theorem eq_correct: + forall s s', + (iswf s) -> (iswf s') -> + (forall i, (contains s i) = (contains s' i)) <-> s = s'. +Proof. + intros s s' WF WF'. + split. + { + intro ALL. + destruct (pset_eq s s') as [ | INEQ]; trivial. + exfalso. + destruct (wf_eq s s' WF WF' INEQ) as [i K]. + specialize ALL with i. + congruence. + } + intro EQ. + subst s'. + trivial. +Qed. + +Lemma wf_irrelevant: + forall s, + forall WF WF' : iswf s, WF = WF'. +Proof. + unfold iswf. + intros. + apply Coq.Logic.Eqdep_dec.eq_proofs_unicity_on. + decide equality. +Qed. + +Fixpoint xelements (s : pset) (i : positive) + (k: list positive) {struct s} + : list positive := + match s with + | Empty => k + | Node b0 false b1 => + xelements b0 (xO i) (xelements b1 (xI i) k) + | Node b0 true b1 => + xelements b0 (xO i) ((prev i) :: xelements b1 (xI i) k) + end. + +Definition elements (m : pset) := xelements m xH nil. + + Remark xelements_append: + forall (m: pset) i k1 k2, + xelements m i (k1 ++ k2) = xelements m i k1 ++ k2. + Proof. + induction m; intros; simpl. + - auto. + - destruct b; rewrite IHm2; rewrite <- IHm1; auto. + Qed. + + Remark xelements_empty: + forall i, xelements Empty i nil = nil. + Proof. + intros; reflexivity. + Qed. + + Remark xelements_node: + forall (m1: pset) o (m2: pset) i, + xelements (Node m1 o m2) i nil = + xelements m1 (xO i) nil + ++ (if o then (prev i) :: nil else nil) + ++ xelements m2 (xI i) nil. + Proof. + intros. simpl. destruct o; simpl; + rewrite <- xelements_append; trivial. + Qed. + + Lemma xelements_incl: + forall (m: pset) (i : positive) k x, + In x k -> In x (xelements m i k). + Proof. + induction m; intros; simpl. + auto. + destruct b. + apply IHm1. simpl; right; auto. + auto. + Qed. + + Lemma xelements_correct: + forall (m: pset) (i j : positive) k, + contains m i=true -> In (prev (prev_append i j)) (xelements m j k). + Proof. + induction m; intros; simpl. + - rewrite gempty in H. discriminate. + - destruct b; destruct i; simpl; simpl in H; auto. + + apply xelements_incl. simpl. + right. auto. + + apply xelements_incl. simpl. + left. trivial. + + apply xelements_incl. auto. + + discriminate. + Qed. + + Theorem elements_correct: + forall (m: pset) (i: positive), + contains m i = true -> In i (elements m). + Proof. + intros m i H. + generalize (xelements_correct m i xH nil H). rewrite prev_append_prev. exact id. + Qed. + + Lemma in_xelements: + forall (m: pset) (i k: positive), + In k (xelements m i nil) -> + exists j, k = prev (prev_append j i) /\ contains m j = true. + Proof. + induction m; intros. + - rewrite xelements_empty in H. contradiction. + - rewrite xelements_node in H. rewrite ! in_app_iff in H. destruct H as [P | [P | P]]. + + specialize IHm1 with (k := k) (i := xO i). + intuition. + destruct H as [j [Q R]]. + exists (xO j). + auto. + + destruct b; simpl in P; intuition auto. subst k. exists xH; auto. + + specialize IHm2 with (k := k) (i := xI i). + intuition. + destruct H as [j [Q R]]. + exists (xI j). + auto. + Qed. + + Theorem elements_complete: + forall (m: pset) (i: positive), + In i (elements m) -> contains m i = true. + Proof. + unfold elements. intros m i H. + destruct (in_xelements m 1 i H) as [j [P Q]]. + rewrite prev_append_prev in P. change i with (prev_append 1 i) in P. + replace j with i in * by (apply prev_append_inj; auto). + assumption. + Qed. + + + Fixpoint xfold {B: Type} (f: B -> positive -> B) + (i: positive) (m: pset) (v: B) {struct m} : B := + match m with + | Empty => v + | Node l false r => + let v1 := xfold f (xO i) l v in + xfold f (xI i) r v1 + | Node l true r => + let v1 := xfold f (xO i) l v in + let v2 := f v1 (prev i) in + xfold f (xI i) r v2 + end. + + Definition fold {B : Type} (f: B -> positive -> B) (m: pset) (v: B) := + xfold f xH m v. + + + Lemma xfold_xelements: + forall {B: Type} (f: B -> positive -> B) m i v l, + List.fold_left f l (xfold f i m v) = + List.fold_left f (xelements m i l) v. + Proof. + induction m; intros; simpl; trivial. + destruct b; simpl. + all: rewrite <- IHm1; simpl; rewrite <- IHm2; trivial. + Qed. + + Theorem fold_spec: + forall {B: Type} (f: B -> positive -> B) (v: B) (m: pset), + fold f m v = + List.fold_left f (elements m) v. + Proof. + intros. unfold fold, elements. rewrite <- xfold_xelements. auto. + Qed. + + Fixpoint is_subset (s s' : pset) {struct s} := + if pset_eq s s' then true else + match s, s' with + | Empty, _ => true + | _, Empty => false + | (Node b0 f b1), (Node b0' f' b1') => + ((negb f) || f') && + (is_subset b0 b0') && + (is_subset b1 b1') + end. + + Theorem is_subset_spec1: + forall s s', + is_subset s s' = true -> + (forall i, contains s i = true -> contains s' i = true). + Proof. + induction s; destruct s'; simpl; intros; trivial. + all: destruct pset_eq. + all: try discriminate. + all: try rewrite gempty in *. + all: try discriminate. + { congruence. + } + repeat rewrite andb_true_iff in H. + repeat rewrite orb_true_iff in H. + repeat rewrite negb_true_iff in H. + specialize IHs1 with (s' := s'1). + specialize IHs2 with (s' := s'2). + intuition. + - destruct i; simpl in *; auto. congruence. + - destruct i; simpl in *; auto. + Qed. + + Theorem is_subset_spec2: + forall s s', + iswf s -> + (forall i, contains s i = true -> contains s' i = true) -> + is_subset s s' = true. + Proof. + induction s; destruct s'; simpl. + all: intro WF. + all: unfold iswf in WF. + all: simpl in WF. + all: repeat rewrite andb_true_iff in WF. + all: destruct pset_eq; trivial. + all: fold (iswf s1) in WF. + all: fold (iswf s2) in WF. + - repeat rewrite orb_true_iff in WF. + repeat rewrite negb_true_iff in WF. + intuition. + + destruct (wf_is_nonempty s1 H2 H1) as [i K]. + specialize H with (xO i). + simpl in H. + auto. + + specialize H with xH. + simpl in H. + auto. + + destruct (wf_is_nonempty s2 H3 H0) as [i K]. + specialize H with (xI i). + simpl in H. + auto. + - intro CONTAINS. + repeat rewrite andb_true_iff. + specialize IHs1 with (s' := s'1). + specialize IHs2 with (s' := s'2). + intuition. + + specialize CONTAINS with xH. + simpl in CONTAINS. + destruct b; destruct b0; intuition congruence. + + apply H. + intros. + specialize CONTAINS with (xO i). + simpl in CONTAINS. + auto. + + apply H3. + intros. + specialize CONTAINS with (xI i). + simpl in CONTAINS. + auto. + Qed. + + Fixpoint xfilter (fn : positive -> bool) + (s : pset) (i : positive) {struct s} : pset := + match s with + | Empty => Empty + | Node b0 f b1 => + node (xfilter fn b0 (xO i)) + (f && (fn (prev i))) + (xfilter fn b1 (xI i)) + end. + + Lemma gxfilter: + forall fn s j i, + contains (xfilter fn s i) j = + contains s j && + (fn (prev (prev_append j i))). + Proof. + induction s; simpl; intros; trivial. + { + rewrite gempty. + trivial. + } + rewrite gnode. + destruct j; simpl; auto. + Qed. + + Definition filter (fn : positive -> bool) m := xfilter fn m xH. + + Lemma gfilter: + forall fn s j, + contains (filter fn s) j = + contains s j && (fn j). + Proof. + intros. + unfold filter. + rewrite gxfilter. + rewrite prev_append_prev. + reflexivity. + Qed. + + Lemma wf_xfilter: + forall fn s j, + iswf s -> iswf (xfilter fn s j). + Proof. + induction s; intros; trivial. + simpl. + unfold iswf in H. + simpl in H. + repeat rewrite andb_true_iff in H. + fold (iswf s1) in H. + fold (iswf s2) in H. + intuition. + Qed. + + Lemma wf_filter: + forall fn s, + iswf s -> iswf (filter fn s). + Proof. + intros. + apply wf_xfilter; auto. + Qed. +End WR. + +Record pset : Type := mkpset +{ + pset_x : WR.pset ; + pset_wf : WR.wf pset_x = true +}. + +Definition t := pset. + +Program Definition empty : t := mkpset WR.empty _. + +Definition contains (s : t) (i : positive) := + WR.contains (pset_x s) i. + +Theorem gempty : + forall i : positive, + contains empty i = false. +Proof. + intro. + unfold empty, contains. + simpl. + auto with pset. +Qed. + +Program Definition add (i : positive) (s : t) := + mkpset (WR.add i (pset_x s)) _. +Obligation 1. + destruct s. + apply WR.wf_add. + simpl. + assumption. +Qed. + +Theorem gaddo : + forall i j : positive, + forall s : t, + i <> j -> + contains (add i s) j = contains s j. +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Theorem gadds : + forall i : positive, + forall s : pset, + contains (add i s) i = true. +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Program Definition remove (i : positive) (s : t) := + mkpset (WR.remove i (pset_x s)) _. +Obligation 1. + destruct s. + apply WR.wf_remove. + simpl. + assumption. +Qed. + +Theorem gremoves : + forall i : positive, + forall s : pset, + contains (remove i s) i = false. +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Theorem gremoveo : + forall i j : positive, + forall s : pset, + i<>j -> + contains (remove i s) j = contains s j. +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Program Definition union (s s' : t) := + mkpset (WR.union (pset_x s) (pset_x s')) _. +Obligation 1. + destruct s; destruct s'. + apply WR.wf_union; simpl; assumption. +Qed. + +Theorem gunion: + forall s s' : pset, + forall j : positive, + (contains (union s s')) j = orb (contains s j) (contains s' j). +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Program Definition inter (s s' : t) := + mkpset (WR.inter (pset_x s) (pset_x s')) _. +Obligation 1. + destruct s; destruct s'. + apply WR.wf_inter; simpl; assumption. +Qed. + +Theorem ginter: + forall s s' : pset, + forall j : positive, + (contains (inter s s')) j = andb (contains s j) (contains s' j). +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Program Definition subtract (s s' : t) := + mkpset (WR.subtract (pset_x s) (pset_x s')) _. +Obligation 1. + destruct s; destruct s'. + apply WR.wf_subtract; simpl; assumption. +Qed. + +Theorem gsubtract: + forall s s' : pset, + forall j : positive, + (contains (subtract s s')) j = andb (contains s j) (negb (contains s' j)). +Proof. + intros. + unfold contains. + simpl. + auto with pset. +Qed. + +Theorem uneq_exists : + forall s s', s <> s' -> + exists i, (contains s i) <> (contains s' i). +Proof. + destruct s as [s WF]; destruct s' as [s' WF']; simpl. + intro UNEQ. + destruct (WR.pset_eq s s'). + { subst s'. + pose proof (WR.wf_irrelevant s WF WF'). + subst WF'. + congruence. + } + unfold contains; simpl. + apply WR.wf_eq; trivial. +Qed. + +Definition eq: + forall s s' : t, {s = s'} + {s <> s'}. +Proof. + destruct s as [s WF]. + destruct s' as [s' WF']. + destruct (WR.pset_eq s s'); simpl. + { + subst s'. + left. + pose proof (WR.wf_irrelevant s WF WF'). + subst WF'. + reflexivity. + } + right. + congruence. +Qed. + +Theorem eq_spec : + forall s s', + (forall i, (contains s i) = (contains s' i)) <-> s = s'. +Proof. + intros. + split; intro K. + 2: subst s'; reflexivity. + destruct s as [s WF]. + destruct s' as [s' WF']. + unfold contains in K. + simpl in K. + fold (WR.iswf s) in WF. + fold (WR.iswf s') in WF'. + assert (s = s'). + { + apply WR.eq_correct; assumption. + } + subst s'. + pose proof (WR.wf_irrelevant s WF WF'). + subst WF'. + reflexivity. +Qed. + + +Definition elements (m : t) := WR.elements (pset_x m). + + +Theorem elements_correct: + forall (m: pset) (i: positive), + contains m i = true -> In i (elements m). +Proof. + destruct m; unfold elements, contains; simpl. + apply WR.elements_correct. +Qed. + + +Theorem elements_complete: + forall (m: pset) (i: positive), + In i (elements m) -> contains m i = true. +Proof. + destruct m; unfold elements, contains; simpl. + apply WR.elements_complete. +Qed. + + +Definition fold {B : Type} (f : B -> positive -> B) (m : t) (v : B) : B := + WR.fold f (pset_x m) v. + +Theorem fold_spec: + forall {B: Type} (f: B -> positive -> B) (v: B) (m: pset), + fold f m v = + List.fold_left f (elements m) v. +Proof. + destruct m; unfold fold, elements; simpl. + apply WR.fold_spec. +Qed. + +Definition is_subset (s s' : t) := WR.is_subset (pset_x s) (pset_x s'). + +Theorem is_subset_spec1: + forall s s', + is_subset s s' = true -> + (forall i, contains s i = true -> contains s' i = true). +Proof. + unfold is_subset, contains. + intros s s' H. + apply WR.is_subset_spec1. + assumption. +Qed. + +Theorem is_subset_spec2: + forall s s', + (forall i, contains s i = true -> contains s' i = true) -> + is_subset s s' = true. +Proof. + destruct s; destruct s'; + unfold is_subset, contains; + intros. + apply WR.is_subset_spec2. + all: simpl. + all: assumption. +Qed. + +Hint Resolve is_subset_spec1 is_subset_spec2 : pset. + +Theorem is_subset_spec: + forall s s', + is_subset s s' = true <-> + (forall i, contains s i = true -> contains s' i = true). +Proof. + intros. + split; + eauto with pset. +Qed. + +Program Definition filter (fn : positive -> bool) (m : t) : t := + (mkpset (WR.filter fn (pset_x m)) _). +Obligation 1. + apply WR.wf_filter. + unfold WR.iswf. + destruct m. + assumption. +Qed. + +Theorem gfilter: + forall fn s j, + contains (filter fn s) j = + contains s j && (fn j). +Proof. + unfold contains, filter. + simpl. + intros. + apply WR.gfilter. +Qed. diff --git a/lib/HashedSetaux.ml b/lib/HashedSetaux.ml new file mode 100644 index 00000000..8329c249 --- /dev/null +++ b/lib/HashedSetaux.ml @@ -0,0 +1,55 @@ +type uid = int + +let uid_base = min_int +let next_uid = ref (uid_base+1) + +let incr_uid () = + let r = !next_uid in + if r = max_int + then failwith "HashedSet: no more uid" + else next_uid := succ r;; + +let cur_uid () = !next_uid;; + +type pset = + | Empty + | Node of uid * pset * bool * pset;; + +let get_uid = function + | Empty -> uid_base + | Node(uid, _, _, _) -> uid;; + +module HashedPSet = + struct + type t = pset + + let hash = function + | Empty -> 0 + | Node(_, b0, f, b1) -> Hashtbl.hash (get_uid b0, f, get_uid b1);; + + let equal x x' = match x, x' with + | Empty, Empty -> true + | Node(_, b0, f, b1), Node(_, b0', f', b1') -> + b0 == b0' && f == f' && b1 == b1' + | _, _ -> false + end;; + +module PSetHash = Weak.Make(HashedPSet);; + +let htable = PSetHash.create 1000;; + +let qnode b0 f b1 = + let x = Node(cur_uid(), b0, f, b1) in + match PSetHash.find_opt htable x with + | None -> PSetHash.add htable x; incr_uid(); x + | Some y -> y;; + +let node (b0, f, b1) = qnode b0 f b1;; + +let empty = Empty;; + +let pset_match empty_case node_case = function + | Empty -> empty_case () + | Node(_, b0, f, b1) -> node_case b0 f b1;; + +let eq (x : pset) (y : pset) = (x==y);; diff --git a/lib/HashedSetaux.mli b/lib/HashedSetaux.mli new file mode 100644 index 00000000..14beac41 --- /dev/null +++ b/lib/HashedSetaux.mli @@ -0,0 +1,6 @@ +type pset +val qnode : pset -> bool -> pset -> pset +val node : pset * bool * pset -> pset +val empty : pset +val pset_match : (unit -> 'a) -> (pset -> bool -> pset -> 'a) -> pset -> 'a +val eq : pset -> pset -> bool diff --git a/lib/Lattice.v b/lib/Lattice.v index 85fc03f3..2b81f7af 100644 --- a/lib/Lattice.v +++ b/lib/Lattice.v @@ -61,6 +61,121 @@ Module Type SEMILATTICE_WITH_TOP. End SEMILATTICE_WITH_TOP. + +Module Type SEMILATTICE_WITHOUT_BOTTOM. + + Parameter t: Type. + Parameter eq: t -> t -> Prop. + Axiom eq_refl: forall x, eq x x. + Axiom eq_sym: forall x y, eq x y -> eq y x. + Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z. + Parameter beq: t -> t -> bool. + Axiom beq_correct: forall x y, beq x y = true -> eq x y. + Parameter ge: t -> t -> Prop. + Axiom ge_refl: forall x y, eq x y -> ge x y. + Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Parameter lub: t -> t -> t. + Axiom ge_lub_left: forall x y, ge (lub x y) x. + Axiom ge_lub_right: forall x y, ge (lub x y) y. + +End SEMILATTICE_WITHOUT_BOTTOM. + +Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM). + Definition t := option L.t. + Definition eq (a b : t) := + match a, b with + | None, None => True + | Some x, Some y => L.eq x y + | Some _, None | None, Some _ => False + end. + + Lemma eq_refl: forall x, eq x x. + Proof. + unfold eq; destruct x; trivial. + apply L.eq_refl. + Qed. + + Lemma eq_sym: forall x y, eq x y -> eq y x. + Proof. + unfold eq; destruct x; destruct y; trivial. + apply L.eq_sym. + Qed. + + Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. + Proof. + unfold eq; destruct x; destruct y; destruct z; trivial. + - apply L.eq_trans. + - contradiction. + Qed. + + Definition beq (x y : t) := + match x, y with + | None, None => true + | Some x, Some y => L.beq x y + | Some _, None | None, Some _ => false + end. + + Lemma beq_correct: forall x y, beq x y = true -> eq x y. + Proof. + unfold beq, eq. + destruct x; destruct y; trivial; try congruence. + apply L.beq_correct. + Qed. + + Definition ge (x y : t) := + match x, y with + | None, Some _ => False + | _, None => True + | Some a, Some b => L.ge a b + end. + + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge. + destruct x; destruct y; trivial. + apply L.ge_refl. + Qed. + + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge. + destruct x; destruct y; destruct z; trivial; try contradiction. + apply L.ge_trans. + Qed. + + Definition bot: t := None. + Lemma ge_bot: forall x, ge x bot. + Proof. + unfold ge, bot. + destruct x; trivial. + Qed. + + Definition lub (a b : t) := + match a, b with + | None, _ => b + | _, None => a + | (Some x), (Some y) => Some (L.lub x y) + end. + + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold ge, lub. + destruct x; destruct y; trivial. + - apply L.ge_lub_left. + - apply L.ge_refl. + apply L.eq_refl. + Qed. + + Lemma ge_lub_right: forall x y, ge (lub x y) y. + Proof. + unfold ge, lub. + destruct x; destruct y; trivial. + - apply L.ge_lub_right. + - apply L.ge_refl. + apply L.eq_refl. + Qed. +End ADD_BOTTOM. + (** * Semi-lattice over maps *) Set Implicit Arguments. -- cgit From b6c4a550705b36254aab812efd7b256e3cea7b51 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 16:31:21 +0100 Subject: HashedSet with module types --- lib/HashedSet.v | 115 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) diff --git a/lib/HashedSet.v b/lib/HashedSet.v index bf781a49..00074a43 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -3,6 +3,120 @@ Require Import Bool. Require Import List. Require Coq.Logic.Eqdep_dec. +Module Type POSITIVE_SET. +Parameter t : Type. +Parameter empty : t. + +Parameter contains: t -> positive -> bool. + +Axiom gempty : + forall i : positive, + contains empty i = false. + +Parameter add : positive -> t -> t. + +Axiom gaddo : + forall i j : positive, + forall s : t, + i <> j -> + contains (add i s) j = contains s j. + +Axiom gadds : + forall i : positive, + forall s : t, + contains (add i s) i = true. + +Parameter remove : positive -> t -> t. + +Axiom gremoves : + forall i : positive, + forall s : t, + contains (remove i s) i = false. + +Axiom gremoveo : + forall i j : positive, + forall s : t, + i<>j -> + contains (remove i s) j = contains s j. + +Parameter union : t -> t -> t. + +Axiom gunion: + forall s s' : t, + forall j : positive, + (contains (union s s')) j = orb (contains s j) (contains s' j). + +Parameter inter : t -> t -> t. + +Axiom ginter: + forall s s' : t, + forall j : positive, + (contains (inter s s')) j = andb (contains s j) (contains s' j). + +Parameter subtract : t -> t -> t. + +Axiom gsubtract: + forall s s' : t, + forall j : positive, + (contains (subtract s s')) j = andb (contains s j) (negb (contains s' j)). + +Axiom uneq_exists : + forall s s', s <> s' -> + exists i, (contains s i) <> (contains s' i). + +Parameter eq: + forall s s' : t, {s = s'} + {s <> s'}. + +Axiom eq_spec : + forall s s', + (forall i, (contains s i) = (contains s' i)) <-> s = s'. + +Parameter elements : t -> list positive. + +Axiom elements_correct: + forall (m: t) (i: positive), + contains m i = true -> In i (elements m). + +Axiom elements_complete: + forall (m: t) (i: positive), + In i (elements m) -> contains m i = true. + +Parameter fold: + forall {B : Type}, + (B -> positive -> B) -> t -> B -> B. + +Axiom fold_spec: + forall {B: Type} (f: B -> positive -> B) (v: B) (m: t), + fold f m v = + List.fold_left f (elements m) v. + +Parameter is_subset : t -> t -> bool. + +Axiom is_subset_spec1: + forall s s', + is_subset s s' = true -> + (forall i, contains s i = true -> contains s' i = true). + +Axiom is_subset_spec2: + forall s s', + (forall i, contains s i = true -> contains s' i = true) -> + is_subset s s' = true. + +Axiom is_subset_spec: + forall s s', + is_subset s s' = true <-> + (forall i, contains s i = true -> contains s' i = true). + +Parameter filter: (positive -> bool) -> t -> t. + +Axiom gfilter: + forall fn s j, + contains (filter fn s) j = + contains s j && (fn j). + +End POSITIVE_SET. + +Module PSet <: POSITIVE_SET. (* begin from Maps *) Fixpoint prev_append (i j: positive) {struct i} : positive := match i with @@ -1268,3 +1382,4 @@ Proof. intros. apply WR.gfilter. Qed. +End PSet. -- cgit From ad16b6526aa5ccbb895053e59bf03ba19beedbad Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 16:34:40 +0100 Subject: HashedSet with extraction --- lib/HashedSet.v | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/HashedSet.v b/lib/HashedSet.v index 00074a43..6130ba17 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -1383,3 +1383,9 @@ Proof. apply WR.gfilter. Qed. End PSet. + +Require Extraction. + +Extract Inductive PSet.WR.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". + +Extract Inlined Constant PSet.WR.pset_eq => "HashedSetaux.eq". -- cgit From 660c1ec3bb6e52720660d6fbb054884b12dca9ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 16:50:51 +0100 Subject: begin CSE3 --- backend/CSE3.v | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 backend/CSE3.v diff --git a/backend/CSE3.v b/backend/CSE3.v new file mode 100644 index 00000000..5479d3f7 --- /dev/null +++ b/backend/CSE3.v @@ -0,0 +1,76 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps CSE2deps. +Require Import HashedSet. + +Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. + Definition t := PSet.t. + Definition eq (x : t) (y : t) := x = y. + + Lemma eq_refl: forall x, eq x x. + Proof. + unfold eq. trivial. + Qed. + + Lemma eq_sym: forall x y, eq x y -> eq y x. + Proof. + unfold eq. congruence. + Qed. + + Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. + Proof. + unfold eq. congruence. + Qed. + + Definition beq (x y : t) := if PSet.eq x y then true else false. + + Lemma beq_correct: forall x y, beq x y = true -> eq x y. + Proof. + unfold beq. + intros. + destruct PSet.eq; congruence. + Qed. + + Definition ge (x y : t) := (PSet.is_subset x y) = true. + + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge. + intros. + subst y. + apply PSet.is_subset_spec. + trivial. + Qed. + + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge. + intros. + rewrite PSet.is_subset_spec in *. + intuition. + Qed. + + Definition lub := PSet.inter. + + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold ge, lub. + intros. + apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + Qed. + + Lemma ge_lub_right: forall x y, ge (lub x y) y. + Proof. + unfold ge, lub. + intros. + apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + Qed. +End RELATION. -- cgit From 78c4974c0a362cd0ab3bbd80203c0277d267afbb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 16:57:54 +0100 Subject: streamlined lattice code --- backend/CSE2.v | 115 +----------------------------------------------------- driver/Compiler.v | 1 + lib/HashedSet.v | 12 +++--- lib/Lattice.v | 33 +++++----------- 4 files changed, 17 insertions(+), 144 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index be72405b..99ecc623 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -29,7 +29,7 @@ Proof. decide equality. Defined. -Module RELATION. +Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. Definition t := (PTree.t sym_val). Definition eq (r1 r2 : t) := @@ -138,119 +138,6 @@ Qed. End RELATION. -Module Type SEMILATTICE_WITHOUT_BOTTOM. - - Parameter t: Type. - Parameter eq: t -> t -> Prop. - Axiom eq_refl: forall x, eq x x. - Axiom eq_sym: forall x y, eq x y -> eq y x. - Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z. - Parameter beq: t -> t -> bool. - Axiom beq_correct: forall x y, beq x y = true -> eq x y. - Parameter ge: t -> t -> Prop. - Axiom ge_refl: forall x y, eq x y -> ge x y. - Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Parameter lub: t -> t -> t. - Axiom ge_lub_left: forall x y, ge (lub x y) x. - Axiom ge_lub_right: forall x y, ge (lub x y) y. - -End SEMILATTICE_WITHOUT_BOTTOM. - -Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM). - Definition t := option L.t. - Definition eq (a b : t) := - match a, b with - | None, None => True - | Some x, Some y => L.eq x y - | Some _, None | None, Some _ => False - end. - - Lemma eq_refl: forall x, eq x x. - Proof. - unfold eq; destruct x; trivial. - apply L.eq_refl. - Qed. - - Lemma eq_sym: forall x y, eq x y -> eq y x. - Proof. - unfold eq; destruct x; destruct y; trivial. - apply L.eq_sym. - Qed. - - Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. - Proof. - unfold eq; destruct x; destruct y; destruct z; trivial. - - apply L.eq_trans. - - contradiction. - Qed. - - Definition beq (x y : t) := - match x, y with - | None, None => true - | Some x, Some y => L.beq x y - | Some _, None | None, Some _ => false - end. - - Lemma beq_correct: forall x y, beq x y = true -> eq x y. - Proof. - unfold beq, eq. - destruct x; destruct y; trivial; try congruence. - apply L.beq_correct. - Qed. - - Definition ge (x y : t) := - match x, y with - | None, Some _ => False - | _, None => True - | Some a, Some b => L.ge a b - end. - - Lemma ge_refl: forall x y, eq x y -> ge x y. - Proof. - unfold eq, ge. - destruct x; destruct y; trivial. - apply L.ge_refl. - Qed. - - Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Proof. - unfold ge. - destruct x; destruct y; destruct z; trivial; try contradiction. - apply L.ge_trans. - Qed. - - Definition bot: t := None. - Lemma ge_bot: forall x, ge x bot. - Proof. - unfold ge, bot. - destruct x; trivial. - Qed. - - Definition lub (a b : t) := - match a, b with - | None, _ => b - | _, None => a - | (Some x), (Some y) => Some (L.lub x y) - end. - - Lemma ge_lub_left: forall x y, ge (lub x y) x. - Proof. - unfold ge, lub. - destruct x; destruct y; trivial. - - apply L.ge_lub_left. - - apply L.ge_refl. - apply L.eq_refl. - Qed. - - Lemma ge_lub_right: forall x y, ge (lub x y) y. - Proof. - unfold ge, lub. - destruct x; destruct y; trivial. - - apply L.ge_lub_right. - - apply L.ge_refl. - apply L.eq_refl. - Qed. -End ADD_BOTTOM. Module RB := ADD_BOTTOM(RELATION). Module DS := Dataflow_Solver(RB)(NodeSetForward). diff --git a/driver/Compiler.v b/driver/Compiler.v index 499feff2..294aad1f 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -43,6 +43,7 @@ Require Constprop. Require CSE. Require ForwardMoves. Require CSE2. +Require CSE3. Require Deadcode. Require Unusedglob. Require Allnontrap. diff --git a/lib/HashedSet.v b/lib/HashedSet.v index 6130ba17..2a798727 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -3,6 +3,8 @@ Require Import Bool. Require Import List. Require Coq.Logic.Eqdep_dec. +Require Extraction. + Module Type POSITIVE_SET. Parameter t : Type. Parameter empty : t. @@ -116,7 +118,7 @@ Axiom gfilter: End POSITIVE_SET. -Module PSet <: POSITIVE_SET. +Module PSet : POSITIVE_SET. (* begin from Maps *) Fixpoint prev_append (i j: positive) {struct i} : positive := match i with @@ -1382,10 +1384,8 @@ Proof. intros. apply WR.gfilter. Qed. -End PSet. -Require Extraction. - -Extract Inductive PSet.WR.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". +Extract Inductive WR.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". -Extract Inlined Constant PSet.WR.pset_eq => "HashedSetaux.eq". +Extract Inlined Constant WR.pset_eq => "HashedSetaux.eq". +End PSet. diff --git a/lib/Lattice.v b/lib/Lattice.v index 2b81f7af..8ea736ad 100644 --- a/lib/Lattice.v +++ b/lib/Lattice.v @@ -30,7 +30,8 @@ Local Unset Case Analysis Schemes. [bot], and an upper bound operation [lub]. Note that we do not demand that [lub] computes the least upper bound. *) -Module Type SEMILATTICE. + +Module Type SEMILATTICE_WITHOUT_BOTTOM. Parameter t: Type. Parameter eq: t -> t -> Prop. @@ -42,45 +43,29 @@ Module Type SEMILATTICE. Parameter ge: t -> t -> Prop. Axiom ge_refl: forall x y, eq x y -> ge x y. Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Parameter bot: t. - Axiom ge_bot: forall x, ge x bot. Parameter lub: t -> t -> t. Axiom ge_lub_left: forall x y, ge (lub x y) x. Axiom ge_lub_right: forall x y, ge (lub x y) y. +End SEMILATTICE_WITHOUT_BOTTOM. + +Module Type SEMILATTICE. + Include SEMILATTICE_WITHOUT_BOTTOM. + Parameter bot: t. + Axiom ge_bot: forall x, ge x bot. End SEMILATTICE. (** A semi-lattice ``with top'' is similar, but also has a greatest element [top]. *) Module Type SEMILATTICE_WITH_TOP. - Include SEMILATTICE. Parameter top: t. Axiom ge_top: forall x, ge top x. - End SEMILATTICE_WITH_TOP. -Module Type SEMILATTICE_WITHOUT_BOTTOM. - - Parameter t: Type. - Parameter eq: t -> t -> Prop. - Axiom eq_refl: forall x, eq x x. - Axiom eq_sym: forall x y, eq x y -> eq y x. - Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z. - Parameter beq: t -> t -> bool. - Axiom beq_correct: forall x y, beq x y = true -> eq x y. - Parameter ge: t -> t -> Prop. - Axiom ge_refl: forall x y, eq x y -> ge x y. - Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Parameter lub: t -> t -> t. - Axiom ge_lub_left: forall x y, ge (lub x y) x. - Axiom ge_lub_right: forall x y, ge (lub x y) y. - -End SEMILATTICE_WITHOUT_BOTTOM. - -Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM). +Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM) <: SEMILATTICE. Definition t := option L.t. Definition eq (a b : t) := match a, b with -- cgit From 028fffbb055b2966b6205c5eaa432d6c4e22f677 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 17:14:14 +0100 Subject: more about extraction and linking --- Makefile | 1 + backend/CSE3.v | 2 + extraction/extraction.v | 7 + lib/HashedSet.v | 365 ++++++++++++++++++++++++------------------------ 4 files changed, 190 insertions(+), 185 deletions(-) diff --git a/Makefile b/Makefile index 2cd40800..4fc94a58 100644 --- a/Makefile +++ b/Makefile @@ -57,6 +57,7 @@ FLOCQ=\ # General-purpose libraries (in lib/) VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ + HashedSet.v \ Iteration.v Zbits.v Integers.v Archi.v IEEE754_extra.v Floats.v \ Parmov.v UnionFind.v Wfsimpl.v \ Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v diff --git a/backend/CSE3.v b/backend/CSE3.v index 5479d3f7..0ac56b36 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -74,3 +74,5 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. intuition. Qed. End RELATION. + +Definition totoro := RELATION.lub. diff --git a/extraction/extraction.v b/extraction/extraction.v index 929c21e0..a258d4d8 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -36,6 +36,8 @@ Require Parser. Require Initializers. Require Asmaux. +Require CSE3. (* FIXME *) + (* Standard lib *) Require Import ExtrOcamlBasic. Require Import ExtrOcamlString. @@ -160,6 +162,10 @@ Extract Constant Cabs.loc => Extract Inlined Constant Cabs.string => "String.t". Extract Constant Cabs.char_code => "int64". +Extract Inductive HashedSet.PSet_internals.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". + +Extract Inlined Constant HashedSet.PSet_internals.pset_eq => "(==)" (* "HashedSetaux.eq" *). + (* Processor-specific extraction directives *) Load extractionMachdep. @@ -182,6 +188,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction + CSE3.totoro (* FIXME *) Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env diff --git a/lib/HashedSet.v b/lib/HashedSet.v index 2a798727..d15637d6 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -3,156 +3,40 @@ Require Import Bool. Require Import List. Require Coq.Logic.Eqdep_dec. -Require Extraction. - -Module Type POSITIVE_SET. -Parameter t : Type. -Parameter empty : t. - -Parameter contains: t -> positive -> bool. - -Axiom gempty : - forall i : positive, - contains empty i = false. - -Parameter add : positive -> t -> t. - -Axiom gaddo : - forall i j : positive, - forall s : t, - i <> j -> - contains (add i s) j = contains s j. - -Axiom gadds : - forall i : positive, - forall s : t, - contains (add i s) i = true. - -Parameter remove : positive -> t -> t. - -Axiom gremoves : - forall i : positive, - forall s : t, - contains (remove i s) i = false. - -Axiom gremoveo : - forall i j : positive, - forall s : t, - i<>j -> - contains (remove i s) j = contains s j. - -Parameter union : t -> t -> t. - -Axiom gunion: - forall s s' : t, - forall j : positive, - (contains (union s s')) j = orb (contains s j) (contains s' j). - -Parameter inter : t -> t -> t. - -Axiom ginter: - forall s s' : t, - forall j : positive, - (contains (inter s s')) j = andb (contains s j) (contains s' j). - -Parameter subtract : t -> t -> t. - -Axiom gsubtract: - forall s s' : t, - forall j : positive, - (contains (subtract s s')) j = andb (contains s j) (negb (contains s' j)). - -Axiom uneq_exists : - forall s s', s <> s' -> - exists i, (contains s i) <> (contains s' i). - -Parameter eq: - forall s s' : t, {s = s'} + {s <> s'}. - -Axiom eq_spec : - forall s s', - (forall i, (contains s i) = (contains s' i)) <-> s = s'. - -Parameter elements : t -> list positive. - -Axiom elements_correct: - forall (m: t) (i: positive), - contains m i = true -> In i (elements m). - -Axiom elements_complete: - forall (m: t) (i: positive), - In i (elements m) -> contains m i = true. - -Parameter fold: - forall {B : Type}, - (B -> positive -> B) -> t -> B -> B. - -Axiom fold_spec: - forall {B: Type} (f: B -> positive -> B) (v: B) (m: t), - fold f m v = - List.fold_left f (elements m) v. - -Parameter is_subset : t -> t -> bool. - -Axiom is_subset_spec1: - forall s s', - is_subset s s' = true -> - (forall i, contains s i = true -> contains s' i = true). - -Axiom is_subset_spec2: - forall s s', - (forall i, contains s i = true -> contains s' i = true) -> - is_subset s s' = true. - -Axiom is_subset_spec: - forall s s', - is_subset s s' = true <-> - (forall i, contains s i = true -> contains s' i = true). - -Parameter filter: (positive -> bool) -> t -> t. - -Axiom gfilter: - forall fn s j, - contains (filter fn s) j = - contains s j && (fn j). - -End POSITIVE_SET. - -Module PSet : POSITIVE_SET. - (* begin from Maps *) - Fixpoint prev_append (i j: positive) {struct i} : positive := - match i with - | xH => j - | xI i' => prev_append i' (xI j) - | xO i' => prev_append i' (xO j) - end. +(* begin from Maps *) +Fixpoint prev_append (i j: positive) {struct i} : positive := + match i with + | xH => j + | xI i' => prev_append i' (xI j) + | xO i' => prev_append i' (xO j) + end. - Definition prev (i: positive) : positive := - prev_append i xH. +Definition prev (i: positive) : positive := + prev_append i xH. - Lemma prev_append_prev i j: - prev (prev_append i j) = prev_append j i. - Proof. - revert j. unfold prev. - induction i as [i IH|i IH|]. 3: reflexivity. - intros j. simpl. rewrite IH. reflexivity. - intros j. simpl. rewrite IH. reflexivity. - Qed. +Lemma prev_append_prev i j: + prev (prev_append i j) = prev_append j i. +Proof. + revert j. unfold prev. + induction i as [i IH|i IH|]. 3: reflexivity. + intros j. simpl. rewrite IH. reflexivity. + intros j. simpl. rewrite IH. reflexivity. +Qed. - Lemma prev_involutive i : - prev (prev i) = i. - Proof (prev_append_prev i xH). +Lemma prev_involutive i : + prev (prev i) = i. +Proof (prev_append_prev i xH). - Lemma prev_append_inj i j j' : - prev_append i j = prev_append i j' -> j = j'. - Proof. - revert j j'. - induction i as [i Hi|i Hi|]; intros j j' H; auto; +Lemma prev_append_inj i j j' : + prev_append i j = prev_append i j' -> j = j'. +Proof. + revert j j'. + induction i as [i Hi|i Hi|]; intros j j' H; auto; specialize (Hi _ _ H); congruence. - Qed. +Qed. + +(* end from Maps *) - (* end from Maps *) - Lemma orb_idem: forall b, orb b b = b. Proof. destruct b; reflexivity. @@ -170,7 +54,7 @@ Qed. Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false: pset. -Module WR. +Module PSet_internals. Inductive pset : Type := | Empty : pset | Node : pset -> bool -> pset -> pset. @@ -1094,20 +978,135 @@ Definition elements (m : pset) := xelements m xH nil. intros. apply wf_xfilter; auto. Qed. -End WR. +End PSet_internals. + +Module Type POSITIVE_SET. +Parameter t : Type. +Parameter empty : t. + +Parameter contains: t -> positive -> bool. + +Axiom gempty : + forall i : positive, + contains empty i = false. + +Parameter add : positive -> t -> t. + +Axiom gaddo : + forall i j : positive, + forall s : t, + i <> j -> + contains (add i s) j = contains s j. + +Axiom gadds : + forall i : positive, + forall s : t, + contains (add i s) i = true. + +Parameter remove : positive -> t -> t. + +Axiom gremoves : + forall i : positive, + forall s : t, + contains (remove i s) i = false. + +Axiom gremoveo : + forall i j : positive, + forall s : t, + i<>j -> + contains (remove i s) j = contains s j. + +Parameter union : t -> t -> t. + +Axiom gunion: + forall s s' : t, + forall j : positive, + (contains (union s s')) j = orb (contains s j) (contains s' j). + +Parameter inter : t -> t -> t. + +Axiom ginter: + forall s s' : t, + forall j : positive, + (contains (inter s s')) j = andb (contains s j) (contains s' j). + +Parameter subtract : t -> t -> t. + +Axiom gsubtract: + forall s s' : t, + forall j : positive, + (contains (subtract s s')) j = andb (contains s j) (negb (contains s' j)). + +Axiom uneq_exists : + forall s s', s <> s' -> + exists i, (contains s i) <> (contains s' i). + +Parameter eq: + forall s s' : t, {s = s'} + {s <> s'}. + +Axiom eq_spec : + forall s s', + (forall i, (contains s i) = (contains s' i)) <-> s = s'. + +Parameter elements : t -> list positive. + +Axiom elements_correct: + forall (m: t) (i: positive), + contains m i = true -> In i (elements m). + +Axiom elements_complete: + forall (m: t) (i: positive), + In i (elements m) -> contains m i = true. + +Parameter fold: + forall {B : Type}, + (B -> positive -> B) -> t -> B -> B. + +Axiom fold_spec: + forall {B: Type} (f: B -> positive -> B) (v: B) (m: t), + fold f m v = + List.fold_left f (elements m) v. + +Parameter is_subset : t -> t -> bool. + +Axiom is_subset_spec1: + forall s s', + is_subset s s' = true -> + (forall i, contains s i = true -> contains s' i = true). + +Axiom is_subset_spec2: + forall s s', + (forall i, contains s i = true -> contains s' i = true) -> + is_subset s s' = true. + +Axiom is_subset_spec: + forall s s', + is_subset s s' = true <-> + (forall i, contains s i = true -> contains s' i = true). + +Parameter filter: (positive -> bool) -> t -> t. + +Axiom gfilter: + forall fn s j, + contains (filter fn s) j = + contains s j && (fn j). + +End POSITIVE_SET. + +Module PSet : POSITIVE_SET. Record pset : Type := mkpset { - pset_x : WR.pset ; - pset_wf : WR.wf pset_x = true + pset_x : PSet_internals.pset ; + pset_wf : PSet_internals.wf pset_x = true }. Definition t := pset. -Program Definition empty : t := mkpset WR.empty _. +Program Definition empty : t := mkpset PSet_internals.empty _. Definition contains (s : t) (i : positive) := - WR.contains (pset_x s) i. + PSet_internals.contains (pset_x s) i. Theorem gempty : forall i : positive, @@ -1120,10 +1119,10 @@ Proof. Qed. Program Definition add (i : positive) (s : t) := - mkpset (WR.add i (pset_x s)) _. + mkpset (PSet_internals.add i (pset_x s)) _. Obligation 1. destruct s. - apply WR.wf_add. + apply PSet_internals.wf_add. simpl. assumption. Qed. @@ -1152,10 +1151,10 @@ Proof. Qed. Program Definition remove (i : positive) (s : t) := - mkpset (WR.remove i (pset_x s)) _. + mkpset (PSet_internals.remove i (pset_x s)) _. Obligation 1. destruct s. - apply WR.wf_remove. + apply PSet_internals.wf_remove. simpl. assumption. Qed. @@ -1184,10 +1183,10 @@ Proof. Qed. Program Definition union (s s' : t) := - mkpset (WR.union (pset_x s) (pset_x s')) _. + mkpset (PSet_internals.union (pset_x s) (pset_x s')) _. Obligation 1. destruct s; destruct s'. - apply WR.wf_union; simpl; assumption. + apply PSet_internals.wf_union; simpl; assumption. Qed. Theorem gunion: @@ -1202,10 +1201,10 @@ Proof. Qed. Program Definition inter (s s' : t) := - mkpset (WR.inter (pset_x s) (pset_x s')) _. + mkpset (PSet_internals.inter (pset_x s) (pset_x s')) _. Obligation 1. destruct s; destruct s'. - apply WR.wf_inter; simpl; assumption. + apply PSet_internals.wf_inter; simpl; assumption. Qed. Theorem ginter: @@ -1220,10 +1219,10 @@ Proof. Qed. Program Definition subtract (s s' : t) := - mkpset (WR.subtract (pset_x s) (pset_x s')) _. + mkpset (PSet_internals.subtract (pset_x s) (pset_x s')) _. Obligation 1. destruct s; destruct s'. - apply WR.wf_subtract; simpl; assumption. + apply PSet_internals.wf_subtract; simpl; assumption. Qed. Theorem gsubtract: @@ -1243,14 +1242,14 @@ Theorem uneq_exists : Proof. destruct s as [s WF]; destruct s' as [s' WF']; simpl. intro UNEQ. - destruct (WR.pset_eq s s'). + destruct (PSet_internals.pset_eq s s'). { subst s'. - pose proof (WR.wf_irrelevant s WF WF'). + pose proof (PSet_internals.wf_irrelevant s WF WF'). subst WF'. congruence. } unfold contains; simpl. - apply WR.wf_eq; trivial. + apply PSet_internals.wf_eq; trivial. Qed. Definition eq: @@ -1258,11 +1257,11 @@ Definition eq: Proof. destruct s as [s WF]. destruct s' as [s' WF']. - destruct (WR.pset_eq s s'); simpl. + destruct (PSet_internals.pset_eq s s'); simpl. { subst s'. left. - pose proof (WR.wf_irrelevant s WF WF'). + pose proof (PSet_internals.wf_irrelevant s WF WF'). subst WF'. reflexivity. } @@ -1281,20 +1280,20 @@ Proof. destruct s' as [s' WF']. unfold contains in K. simpl in K. - fold (WR.iswf s) in WF. - fold (WR.iswf s') in WF'. + fold (PSet_internals.iswf s) in WF. + fold (PSet_internals.iswf s') in WF'. assert (s = s'). { - apply WR.eq_correct; assumption. + apply PSet_internals.eq_correct; assumption. } subst s'. - pose proof (WR.wf_irrelevant s WF WF'). + pose proof (PSet_internals.wf_irrelevant s WF WF'). subst WF'. reflexivity. Qed. -Definition elements (m : t) := WR.elements (pset_x m). +Definition elements (m : t) := PSet_internals.elements (pset_x m). Theorem elements_correct: @@ -1302,7 +1301,7 @@ Theorem elements_correct: contains m i = true -> In i (elements m). Proof. destruct m; unfold elements, contains; simpl. - apply WR.elements_correct. + apply PSet_internals.elements_correct. Qed. @@ -1311,12 +1310,12 @@ Theorem elements_complete: In i (elements m) -> contains m i = true. Proof. destruct m; unfold elements, contains; simpl. - apply WR.elements_complete. + apply PSet_internals.elements_complete. Qed. Definition fold {B : Type} (f : B -> positive -> B) (m : t) (v : B) : B := - WR.fold f (pset_x m) v. + PSet_internals.fold f (pset_x m) v. Theorem fold_spec: forall {B: Type} (f: B -> positive -> B) (v: B) (m: pset), @@ -1324,10 +1323,10 @@ Theorem fold_spec: List.fold_left f (elements m) v. Proof. destruct m; unfold fold, elements; simpl. - apply WR.fold_spec. + apply PSet_internals.fold_spec. Qed. -Definition is_subset (s s' : t) := WR.is_subset (pset_x s) (pset_x s'). +Definition is_subset (s s' : t) := PSet_internals.is_subset (pset_x s) (pset_x s'). Theorem is_subset_spec1: forall s s', @@ -1336,7 +1335,7 @@ Theorem is_subset_spec1: Proof. unfold is_subset, contains. intros s s' H. - apply WR.is_subset_spec1. + apply PSet_internals.is_subset_spec1. assumption. Qed. @@ -1348,7 +1347,7 @@ Proof. destruct s; destruct s'; unfold is_subset, contains; intros. - apply WR.is_subset_spec2. + apply PSet_internals.is_subset_spec2. all: simpl. all: assumption. Qed. @@ -1366,10 +1365,10 @@ Proof. Qed. Program Definition filter (fn : positive -> bool) (m : t) : t := - (mkpset (WR.filter fn (pset_x m)) _). + (mkpset (PSet_internals.filter fn (pset_x m)) _). Obligation 1. - apply WR.wf_filter. - unfold WR.iswf. + apply PSet_internals.wf_filter. + unfold PSet_internals.iswf. destruct m. assumption. Qed. @@ -1382,10 +1381,6 @@ Proof. unfold contains, filter. simpl. intros. - apply WR.gfilter. + apply PSet_internals.gfilter. Qed. - -Extract Inductive WR.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". - -Extract Inlined Constant WR.pset_eq => "HashedSetaux.eq". End PSet. -- cgit From 746b4cd3895462be7959389ef39696294177e465 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 17:29:59 +0100 Subject: fix Makefile --- Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile b/Makefile index 4fc94a58..e51bdb8a 100644 --- a/Makefile +++ b/Makefile @@ -89,6 +89,7 @@ BACKEND=\ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ + CSE3.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ -- cgit From 5e2b2d9a6c85a2ed90eda0fe630a218e8b437c5f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 18:21:46 +0100 Subject: just the analysis --- Makefile | 2 +- backend/CSE3.v | 78 ----------------------------------------------- backend/CSE3analysis.v | 81 +++++++++++++++++++++++++++++++++++++++++++++++++ extraction/extraction.v | 4 +-- 4 files changed, 84 insertions(+), 81 deletions(-) delete mode 100644 backend/CSE3.v create mode 100644 backend/CSE3analysis.v diff --git a/Makefile b/Makefile index e51bdb8a..dc368c66 100644 --- a/Makefile +++ b/Makefile @@ -89,7 +89,7 @@ BACKEND=\ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ - CSE3.v \ + CSE3analysis.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ diff --git a/backend/CSE3.v b/backend/CSE3.v deleted file mode 100644 index 0ac56b36..00000000 --- a/backend/CSE3.v +++ /dev/null @@ -1,78 +0,0 @@ -Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. -Require Import AST Linking. -Require Import Memory Registers Op RTL Maps CSE2deps. -Require Import HashedSet. - -Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. - Definition t := PSet.t. - Definition eq (x : t) (y : t) := x = y. - - Lemma eq_refl: forall x, eq x x. - Proof. - unfold eq. trivial. - Qed. - - Lemma eq_sym: forall x y, eq x y -> eq y x. - Proof. - unfold eq. congruence. - Qed. - - Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. - Proof. - unfold eq. congruence. - Qed. - - Definition beq (x y : t) := if PSet.eq x y then true else false. - - Lemma beq_correct: forall x y, beq x y = true -> eq x y. - Proof. - unfold beq. - intros. - destruct PSet.eq; congruence. - Qed. - - Definition ge (x y : t) := (PSet.is_subset x y) = true. - - Lemma ge_refl: forall x y, eq x y -> ge x y. - Proof. - unfold eq, ge. - intros. - subst y. - apply PSet.is_subset_spec. - trivial. - Qed. - - Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Proof. - unfold ge. - intros. - rewrite PSet.is_subset_spec in *. - intuition. - Qed. - - Definition lub := PSet.inter. - - Lemma ge_lub_left: forall x y, ge (lub x y) x. - Proof. - unfold ge, lub. - intros. - apply PSet.is_subset_spec. - intro. - rewrite PSet.ginter. - rewrite andb_true_iff. - intuition. - Qed. - - Lemma ge_lub_right: forall x y, ge (lub x y) y. - Proof. - unfold ge, lub. - intros. - apply PSet.is_subset_spec. - intro. - rewrite PSet.ginter. - rewrite andb_true_iff. - intuition. - Qed. -End RELATION. - -Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v new file mode 100644 index 00000000..06de1b08 --- /dev/null +++ b/backend/CSE3analysis.v @@ -0,0 +1,81 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps CSE2deps. +Require Import HashedSet. + +Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. + Definition t := PSet.t. + Definition eq (x : t) (y : t) := x = y. + + Lemma eq_refl: forall x, eq x x. + Proof. + unfold eq. trivial. + Qed. + + Lemma eq_sym: forall x y, eq x y -> eq y x. + Proof. + unfold eq. congruence. + Qed. + + Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z. + Proof. + unfold eq. congruence. + Qed. + + Definition beq (x y : t) := if PSet.eq x y then true else false. + + Lemma beq_correct: forall x y, beq x y = true -> eq x y. + Proof. + unfold beq. + intros. + destruct PSet.eq; congruence. + Qed. + + Definition ge (x y : t) := (PSet.is_subset x y) = true. + + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge. + intros. + subst y. + apply PSet.is_subset_spec. + trivial. + Qed. + + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge. + intros. + rewrite PSet.is_subset_spec in *. + intuition. + Qed. + + Definition lub := PSet.inter. + + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold ge, lub. + intros. + apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + Qed. + + Lemma ge_lub_right: forall x y, ge (lub x y) y. + Proof. + unfold ge, lub. + intros. + apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + Qed. +End RELATION. + +Module RB := ADD_BOTTOM(RELATION). +Module DS := Dataflow_Solver(RB)(NodeSetForward). + +Definition totoro := RELATION.lub. diff --git a/extraction/extraction.v b/extraction/extraction.v index a258d4d8..ea30e7c2 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -36,7 +36,7 @@ Require Parser. Require Initializers. Require Asmaux. -Require CSE3. (* FIXME *) +Require CSE3analysis. (* FIXME *) (* Standard lib *) Require Import ExtrOcamlBasic. @@ -188,7 +188,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction - CSE3.totoro (* FIXME *) + CSE3analysis.totoro (* FIXME *) Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env -- cgit From dc13dcbf1138be32db14be0a9e132d8326bb2dc5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 21:10:49 +0100 Subject: xget_kills --- backend/CSE3analysis.v | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 06de1b08..c490ec08 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -78,4 +78,78 @@ End RELATION. Module RB := ADD_BOTTOM(RELATION). Module DS := Dataflow_Solver(RB)(NodeSetForward). +Inductive sym_op : Type := +| SOp : operation -> sym_op +| SLoad : memory_chunk -> addressing -> sym_op. + +Record equation := + mkequation + { eq_lhs : reg; + eq_op : sym_op; + eq_args : list reg }. + +Definition eq_id := positive. + +Definition add_i_j (i : reg) (j : eq_id) (m : Regmap.t PSet.t) := + Regmap.set i (PSet.add j (Regmap.get i m)) m. + +Lemma add_i_j_adds : forall i j m, + PSet.contains (Regmap.get i (add_i_j i j m)) j = true. +Proof. + intros. + unfold add_i_j. + rewrite Regmap.gss. + auto with pset. +Qed. + +Lemma add_i_j_monotone : forall i j i' j' m, + PSet.contains (Regmap.get i' m) j' = true -> + PSet.contains (Regmap.get i' (add_i_j i j m)) j' = true. +Proof. + intros. + unfold add_i_j. + destruct (peq i i'). + - subst i'. + rewrite Regmap.gss. + destruct (peq j j'). + + subst j'. + apply PSet.gadds. + + eauto with pset. + - rewrite Regmap.gso. + assumption. + congruence. +Qed. + +Definition add_ilist_j (ilist : list reg) (j : eq_id) (m : Regmap.t PSet.t) := + List.fold_left (fun already i => add_i_j i j already) ilist m. + +Lemma add_ilist_j_monotone : forall ilist j i' j' m, + PSet.contains (Regmap.get i' m) j' = true -> + PSet.contains (Regmap.get i' (add_ilist_j ilist j m)) j' = true. +Proof. + induction ilist; simpl; intros until m; intro CONTAINS; trivial. + apply IHilist. + apply add_i_j_monotone. + assumption. +Qed. + +Lemma add_ilist_j_adds : forall ilist j m, + forall i, In i ilist -> + PSet.contains (Regmap.get i (add_ilist_j ilist j m)) j = true. +Proof. + induction ilist; simpl; intros until i; intro IN. + contradiction. + destruct IN as [HEAD | TAIL]. + - subst a. + apply add_ilist_j_monotone. + apply add_i_j_adds. + - apply IHilist. + assumption. +Qed. + +Definition xget_kills (eqs : PTree.t equation) := + PTree.fold (fun already (eqno : eq_id) (eq : equation) => + add_i_j (eq_lhs eq) eqno + (add_ilist_j (eq_args eq) eqno already)). + Definition totoro := RELATION.lub. -- cgit From e76b8244db0c8394eb9f62a573ea0f511bd8db31 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 21:26:01 +0100 Subject: CSE3 generate lists of killable --- driver/Compiler.v | 2 +- lib/HashedSet.v | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index 294aad1f..a641587c 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -43,7 +43,7 @@ Require Constprop. Require CSE. Require ForwardMoves. Require CSE2. -Require CSE3. +Require CSE3analysis. Require Deadcode. Require Unusedglob. Require Allnontrap. diff --git a/lib/HashedSet.v b/lib/HashedSet.v index d15637d6..5b4faeaa 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -1384,3 +1384,7 @@ Proof. apply PSet_internals.gfilter. Qed. End PSet. + +Hint Resolve PSet.gaddo PSet.gadds PSet.gremoveo PSet.gremoves PSet.gunion PSet.ginter PSet.gsubtract PSet.gfilter PSet.is_subset_spec1 PSet.is_subset_spec2 : pset. + +Hint Rewrite PSet.gadds PSet.gremoves PSet.gunion PSet.ginter PSet.gsubtract PSet.gfilter : pset. -- cgit From f2b898dfb741210596e5fb92e44094fc0fdb989e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 5 Mar 2020 21:39:43 +0100 Subject: xget_kills_monotone --- backend/CSE3analysis.v | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index c490ec08..3e225fb4 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -146,10 +146,33 @@ Proof. - apply IHilist. assumption. Qed. - -Definition xget_kills (eqs : PTree.t equation) := + +Definition xget_kills (eqs : PTree.t equation) (m : Regmap.t PSet.t) : + Regmap.t PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => add_i_j (eq_lhs eq) eqno - (add_ilist_j (eq_args eq) eqno already)). - + (add_ilist_j (eq_args eq) eqno already)) eqs m. + +Lemma xget_kills_monotone : + forall eqs m i j, + PSet.contains (Regmap.get i m) j = true -> + PSet.contains (Regmap.get i (xget_kills eqs m)) j = true. +Proof. + unfold xget_kills. + intros eqs m. + rewrite PTree.fold_spec. + generalize (PTree.elements eqs). + intro. + generalize m. + clear m. + induction l; simpl; trivial. + intros. + apply IHl. + apply add_i_j_monotone. + apply add_ilist_j_monotone. + assumption. +Qed. + +Definition eq_involves (eq : equation) (i : reg) := + i = (eq_lhs eq) \/ In i (eq_args eq). Definition totoro := RELATION.lub. -- cgit From 5e6f8c2bc49dd2a27eb6886033e6687fb13030fd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Mar 2020 23:41:45 +0100 Subject: xlkills --- backend/CSE3analysis.v | 64 ++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 10 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 3e225fb4..64ddad11 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -101,6 +101,7 @@ Proof. rewrite Regmap.gss. auto with pset. Qed. +Hint Resolve add_i_j_adds: cse3. Lemma add_i_j_monotone : forall i j i' j' m, PSet.contains (Regmap.get i' m) j' = true -> @@ -120,6 +121,8 @@ Proof. congruence. Qed. +Hint Resolve add_i_j_monotone: cse3. + Definition add_ilist_j (ilist : list reg) (j : eq_id) (m : Regmap.t PSet.t) := List.fold_left (fun already i => add_i_j i j already) ilist m. @@ -127,11 +130,9 @@ Lemma add_ilist_j_monotone : forall ilist j i' j' m, PSet.contains (Regmap.get i' m) j' = true -> PSet.contains (Regmap.get i' (add_ilist_j ilist j m)) j' = true. Proof. - induction ilist; simpl; intros until m; intro CONTAINS; trivial. - apply IHilist. - apply add_i_j_monotone. - assumption. + induction ilist; simpl; intros until m; intro CONTAINS; auto with cse3. Qed. +Hint Resolve add_ilist_j_monotone: cse3. Lemma add_ilist_j_adds : forall ilist j m, forall i, In i ilist -> @@ -139,13 +140,9 @@ Lemma add_ilist_j_adds : forall ilist j m, Proof. induction ilist; simpl; intros until i; intro IN. contradiction. - destruct IN as [HEAD | TAIL]. - - subst a. - apply add_ilist_j_monotone. - apply add_i_j_adds. - - apply IHilist. - assumption. + destruct IN as [HEAD | TAIL]; subst; auto with cse3. Qed. +Hint Resolve add_ilist_j_adds: cse3. Definition xget_kills (eqs : PTree.t equation) (m : Regmap.t PSet.t) : Regmap.t PSet.t := @@ -153,6 +150,44 @@ Definition xget_kills (eqs : PTree.t equation) (m : Regmap.t PSet.t) : add_i_j (eq_lhs eq) eqno (add_ilist_j (eq_args eq) eqno already)) eqs m. +Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : + Regmap.t PSet.t := + List.fold_left (fun already (item : eq_id * equation) => + let (eqno,eq) := item in + add_i_j (eq_lhs eq) eqno + (add_ilist_j (eq_args eq) eqno already)) eqs m. + +Lemma xlget_kills_monotone : + forall eqs m i j, + PSet.contains (Regmap.get i m) j = true -> + PSet.contains (Regmap.get i (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl; trivial. + destruct a as [eqno eq]. + intros. + auto with cse3. +Qed. + +Hint Resolve xlget_kills_monotone : cse3. + +Lemma xlget_kills_has_lhs : + forall eqs m lhs sop args j, + In (j, {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |}) eqs -> + PSet.contains (Regmap.get lhs (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros until j. + intro HEAD_TAIL. + destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. + - auto with cse3. + - eapply IHeqs. eassumption. +Qed. +Hint Resolve xlget_kills_has_lhs : cse3. + +(* Lemma xget_kills_monotone : forall eqs m i j, PSet.contains (Regmap.get i m) j = true -> @@ -172,7 +207,16 @@ Proof. apply add_ilist_j_monotone. assumption. Qed. +*) +Lemma xget_kills_has_lhs : + forall eqs m lhs sop args j, + PTree.get j eqs = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + PSet.contains (Regmap.get lhs (xget_kills eqs m)) j = true. Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). + + Definition totoro := RELATION.lub. -- cgit From 45e1539974db9c84d3e6466ac9c5f92afb1b08c6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Mar 2020 23:47:28 +0100 Subject: xlkills --- backend/CSE3analysis.v | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 64ddad11..34633cfc 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -186,7 +186,27 @@ Proof. - eapply IHeqs. eassumption. Qed. Hint Resolve xlget_kills_has_lhs : cse3. - + + +Lemma xlget_kills_has_arg : + forall eqs m lhs sop arg args j, + In (j, {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |}) eqs -> + In arg args -> + PSet.contains (Regmap.get arg (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros until j. + intros HEAD_TAIL ARG. + destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. + - auto with cse3. + - eapply IHeqs; eassumption. +Qed. + +Hint Resolve xlget_kills_has_arg : cse3. + (* Lemma xget_kills_monotone : forall eqs m i j, -- cgit From e9cfef4367a6631f06c3b7ca81faa822326282e8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 6 Mar 2020 23:58:53 +0100 Subject: get_kills_has_lhs --- backend/CSE3analysis.v | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 34633cfc..0240671d 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -144,18 +144,18 @@ Proof. Qed. Hint Resolve add_ilist_j_adds: cse3. -Definition xget_kills (eqs : PTree.t equation) (m : Regmap.t PSet.t) : +Definition get_kills (eqs : PTree.t equation) : Regmap.t PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => add_i_j (eq_lhs eq) eqno - (add_ilist_j (eq_args eq) eqno already)) eqs m. + (add_ilist_j (eq_args eq) eqno already)) eqs + (PMap.init PSet.empty). Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : Regmap.t PSet.t := List.fold_left (fun already (item : eq_id * equation) => - let (eqno,eq) := item in - add_i_j (eq_lhs eq) eqno - (add_ilist_j (eq_args eq) eqno already)) eqs m. + add_i_j (eq_lhs (snd item)) (fst item) + (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. Lemma xlget_kills_monotone : forall eqs m i j, @@ -163,7 +163,6 @@ Lemma xlget_kills_monotone : PSet.contains (Regmap.get i (xlget_kills eqs m)) j = true. Proof. induction eqs; simpl; trivial. - destruct a as [eqno eq]. intros. auto with cse3. Qed. @@ -187,7 +186,6 @@ Proof. Qed. Hint Resolve xlget_kills_has_lhs : cse3. - Lemma xlget_kills_has_arg : forall eqs m lhs sop arg args j, In (j, {| eq_lhs := lhs; @@ -207,6 +205,26 @@ Qed. Hint Resolve xlget_kills_has_arg : cse3. + +Lemma get_kills_has_lhs : + forall eqs lhs sop args j, + PTree.get j eqs = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + PSet.contains (Regmap.get lhs (get_kills eqs)) j = true. +Proof. + unfold get_kills. + intros. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : Regmap.t PSet.t) (p : positive * equation) => + add_i_j (eq_lhs (snd p)) (fst p) + (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. + eapply xlget_kills_has_lhs. + apply PTree.elements_correct. + eassumption. +Qed. + (* Lemma xget_kills_monotone : forall eqs m i j, -- cgit From a3e4da1161853ed2911af39621200794f730e4ff Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Mar 2020 00:01:44 +0100 Subject: get_kills_has_arg --- backend/CSE3analysis.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 0240671d..92d9202a 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -225,6 +225,27 @@ Proof. eassumption. Qed. +Lemma get_kills_has_arg : + forall eqs lhs sop arg args j, + PTree.get j eqs = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + In arg args -> + PSet.contains (Regmap.get arg (get_kills eqs)) j = true. +Proof. + unfold get_kills. + intros. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : Regmap.t PSet.t) (p : positive * equation) => + add_i_j (eq_lhs (snd p)) (fst p) + (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. + eapply xlget_kills_has_arg. + - apply PTree.elements_correct. + eassumption. + - assumption. +Qed. + (* Lemma xget_kills_monotone : forall eqs m i j, -- cgit From 2f5c9ad58ee548be71c650784f0fd997852034b4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 7 Mar 2020 22:21:15 +0100 Subject: CSE3 analysis proof --- backend/CSE3analysisproof.v | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) create mode 100644 backend/CSE3analysisproof.v diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v new file mode 100644 index 00000000..f864377e --- /dev/null +++ b/backend/CSE3analysisproof.v @@ -0,0 +1,35 @@ + +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE3analysis CSE2deps CSE2depsproof. +Require Import Lia. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + + Definition eq_sem (eq : equation) (rs : regset) (m : mem) := + match eq_op eq with + | SOp op => + match eval_operation genv sp op (rs ## (eq_args eq)) m with + | Some v => rs # (eq_lhs eq) = v + | None => False + end + | SLoad chunk addr => + match + match eval_addressing genv sp addr rs##(eq_args eq) with + | Some a => Mem.loadv chunk m a + | None => None + end + with + | Some dat => rs # (eq_lhs eq) = dat + | None => rs # (eq_lhs eq) = default_notrap_load_value chunk + end + end. +End SOUNDNESS. -- cgit From 3c34c386912e904b432c53e1dbb2b3dda3f8501f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 16:23:36 +0100 Subject: moved stuff around --- backend/CSE3analysis.v | 175 -------------------------------------------- backend/CSE3analysisproof.v | 157 ++++++++++++++++++++++++++++++++++++++- 2 files changed, 155 insertions(+), 177 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 92d9202a..257149b5 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -93,57 +93,9 @@ Definition eq_id := positive. Definition add_i_j (i : reg) (j : eq_id) (m : Regmap.t PSet.t) := Regmap.set i (PSet.add j (Regmap.get i m)) m. -Lemma add_i_j_adds : forall i j m, - PSet.contains (Regmap.get i (add_i_j i j m)) j = true. -Proof. - intros. - unfold add_i_j. - rewrite Regmap.gss. - auto with pset. -Qed. -Hint Resolve add_i_j_adds: cse3. - -Lemma add_i_j_monotone : forall i j i' j' m, - PSet.contains (Regmap.get i' m) j' = true -> - PSet.contains (Regmap.get i' (add_i_j i j m)) j' = true. -Proof. - intros. - unfold add_i_j. - destruct (peq i i'). - - subst i'. - rewrite Regmap.gss. - destruct (peq j j'). - + subst j'. - apply PSet.gadds. - + eauto with pset. - - rewrite Regmap.gso. - assumption. - congruence. -Qed. - -Hint Resolve add_i_j_monotone: cse3. - Definition add_ilist_j (ilist : list reg) (j : eq_id) (m : Regmap.t PSet.t) := List.fold_left (fun already i => add_i_j i j already) ilist m. -Lemma add_ilist_j_monotone : forall ilist j i' j' m, - PSet.contains (Regmap.get i' m) j' = true -> - PSet.contains (Regmap.get i' (add_ilist_j ilist j m)) j' = true. -Proof. - induction ilist; simpl; intros until m; intro CONTAINS; auto with cse3. -Qed. -Hint Resolve add_ilist_j_monotone: cse3. - -Lemma add_ilist_j_adds : forall ilist j m, - forall i, In i ilist -> - PSet.contains (Regmap.get i (add_ilist_j ilist j m)) j = true. -Proof. - induction ilist; simpl; intros until i; intro IN. - contradiction. - destruct IN as [HEAD | TAIL]; subst; auto with cse3. -Qed. -Hint Resolve add_ilist_j_adds: cse3. - Definition get_kills (eqs : PTree.t equation) : Regmap.t PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => @@ -151,131 +103,4 @@ Definition get_kills (eqs : PTree.t equation) : (add_ilist_j (eq_args eq) eqno already)) eqs (PMap.init PSet.empty). -Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : - Regmap.t PSet.t := - List.fold_left (fun already (item : eq_id * equation) => - add_i_j (eq_lhs (snd item)) (fst item) - (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. - -Lemma xlget_kills_monotone : - forall eqs m i j, - PSet.contains (Regmap.get i m) j = true -> - PSet.contains (Regmap.get i (xlget_kills eqs m)) j = true. -Proof. - induction eqs; simpl; trivial. - intros. - auto with cse3. -Qed. - -Hint Resolve xlget_kills_monotone : cse3. - -Lemma xlget_kills_has_lhs : - forall eqs m lhs sop args j, - In (j, {| eq_lhs := lhs; - eq_op := sop; - eq_args:= args |}) eqs -> - PSet.contains (Regmap.get lhs (xlget_kills eqs m)) j = true. -Proof. - induction eqs; simpl. - contradiction. - intros until j. - intro HEAD_TAIL. - destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. - - auto with cse3. - - eapply IHeqs. eassumption. -Qed. -Hint Resolve xlget_kills_has_lhs : cse3. - -Lemma xlget_kills_has_arg : - forall eqs m lhs sop arg args j, - In (j, {| eq_lhs := lhs; - eq_op := sop; - eq_args:= args |}) eqs -> - In arg args -> - PSet.contains (Regmap.get arg (xlget_kills eqs m)) j = true. -Proof. - induction eqs; simpl. - contradiction. - intros until j. - intros HEAD_TAIL ARG. - destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. - - auto with cse3. - - eapply IHeqs; eassumption. -Qed. - -Hint Resolve xlget_kills_has_arg : cse3. - - -Lemma get_kills_has_lhs : - forall eqs lhs sop args j, - PTree.get j eqs = Some {| eq_lhs := lhs; - eq_op := sop; - eq_args:= args |} -> - PSet.contains (Regmap.get lhs (get_kills eqs)) j = true. -Proof. - unfold get_kills. - intros. - rewrite PTree.fold_spec. - change (fold_left - (fun (a : Regmap.t PSet.t) (p : positive * equation) => - add_i_j (eq_lhs (snd p)) (fst p) - (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. - eapply xlget_kills_has_lhs. - apply PTree.elements_correct. - eassumption. -Qed. - -Lemma get_kills_has_arg : - forall eqs lhs sop arg args j, - PTree.get j eqs = Some {| eq_lhs := lhs; - eq_op := sop; - eq_args:= args |} -> - In arg args -> - PSet.contains (Regmap.get arg (get_kills eqs)) j = true. -Proof. - unfold get_kills. - intros. - rewrite PTree.fold_spec. - change (fold_left - (fun (a : Regmap.t PSet.t) (p : positive * equation) => - add_i_j (eq_lhs (snd p)) (fst p) - (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. - eapply xlget_kills_has_arg. - - apply PTree.elements_correct. - eassumption. - - assumption. -Qed. - -(* -Lemma xget_kills_monotone : - forall eqs m i j, - PSet.contains (Regmap.get i m) j = true -> - PSet.contains (Regmap.get i (xget_kills eqs m)) j = true. -Proof. - unfold xget_kills. - intros eqs m. - rewrite PTree.fold_spec. - generalize (PTree.elements eqs). - intro. - generalize m. - clear m. - induction l; simpl; trivial. - intros. - apply IHl. - apply add_i_j_monotone. - apply add_ilist_j_monotone. - assumption. -Qed. -*) -Lemma xget_kills_has_lhs : - forall eqs m lhs sop args j, - PTree.get j eqs = Some {| eq_lhs := lhs; - eq_op := sop; - eq_args:= args |} -> - PSet.contains (Regmap.get lhs (xget_kills eqs m)) j = true. - -Definition eq_involves (eq : equation) (i : reg) := - i = (eq_lhs eq) \/ In i (eq_args eq). - - Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index f864377e..af42a2e8 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -6,15 +6,162 @@ Require Import Memory Registers Op RTL Maps. Require Import Globalenvs Values. Require Import Linking Values Memory Globalenvs Events Smallstep. Require Import Registers Op RTL. -Require Import CSE3analysis CSE2deps CSE2depsproof. +Require Import CSE3analysis CSE2deps CSE2depsproof HashedSet. Require Import Lia. +Lemma add_i_j_adds : forall i j m, + PSet.contains (Regmap.get i (add_i_j i j m)) j = true. +Proof. + intros. + unfold add_i_j. + rewrite Regmap.gss. + auto with pset. +Qed. +Hint Resolve add_i_j_adds: cse3. + +Lemma add_i_j_monotone : forall i j i' j' m, + PSet.contains (Regmap.get i' m) j' = true -> + PSet.contains (Regmap.get i' (add_i_j i j m)) j' = true. +Proof. + intros. + unfold add_i_j. + destruct (peq i i'). + - subst i'. + rewrite Regmap.gss. + destruct (peq j j'). + + subst j'. + apply PSet.gadds. + + eauto with pset. + - rewrite Regmap.gso. + assumption. + congruence. +Qed. + +Hint Resolve add_i_j_monotone: cse3. + +Lemma add_ilist_j_monotone : forall ilist j i' j' m, + PSet.contains (Regmap.get i' m) j' = true -> + PSet.contains (Regmap.get i' (add_ilist_j ilist j m)) j' = true. +Proof. + induction ilist; simpl; intros until m; intro CONTAINS; auto with cse3. +Qed. +Hint Resolve add_ilist_j_monotone: cse3. + +Lemma add_ilist_j_adds : forall ilist j m, + forall i, In i ilist -> + PSet.contains (Regmap.get i (add_ilist_j ilist j m)) j = true. +Proof. + induction ilist; simpl; intros until i; intro IN. + contradiction. + destruct IN as [HEAD | TAIL]; subst; auto with cse3. +Qed. +Hint Resolve add_ilist_j_adds: cse3. + +Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : + Regmap.t PSet.t := + List.fold_left (fun already (item : eq_id * equation) => + add_i_j (eq_lhs (snd item)) (fst item) + (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. + +Lemma xlget_kills_monotone : + forall eqs m i j, + PSet.contains (Regmap.get i m) j = true -> + PSet.contains (Regmap.get i (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl; trivial. + intros. + auto with cse3. +Qed. + +Hint Resolve xlget_kills_monotone : cse3. + +Lemma xlget_kills_has_lhs : + forall eqs m lhs sop args j, + In (j, {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |}) eqs -> + PSet.contains (Regmap.get lhs (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros until j. + intro HEAD_TAIL. + destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. + - auto with cse3. + - eapply IHeqs. eassumption. +Qed. +Hint Resolve xlget_kills_has_lhs : cse3. + +Lemma xlget_kills_has_arg : + forall eqs m lhs sop arg args j, + In (j, {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |}) eqs -> + In arg args -> + PSet.contains (Regmap.get arg (xlget_kills eqs m)) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros until j. + intros HEAD_TAIL ARG. + destruct HEAD_TAIL as [HEAD | TAIL]; subst; simpl. + - auto with cse3. + - eapply IHeqs; eassumption. +Qed. + +Hint Resolve xlget_kills_has_arg : cse3. + +Lemma get_kills_has_lhs : + forall eqs lhs sop args j, + PTree.get j eqs = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + PSet.contains (Regmap.get lhs (get_kills eqs)) j = true. +Proof. + unfold get_kills. + intros. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : Regmap.t PSet.t) (p : positive * equation) => + add_i_j (eq_lhs (snd p)) (fst p) + (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. + eapply xlget_kills_has_lhs. + apply PTree.elements_correct. + eassumption. +Qed. + +Lemma get_kills_has_arg : + forall eqs lhs sop arg args j, + PTree.get j eqs = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + In arg args -> + PSet.contains (Regmap.get arg (get_kills eqs)) j = true. +Proof. + unfold get_kills. + intros. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : Regmap.t PSet.t) (p : positive * equation) => + add_i_j (eq_lhs (snd p)) (fst p) + (add_ilist_j (eq_args (snd p)) (fst p) a))) with xlget_kills. + eapply xlget_kills_has_arg. + - apply PTree.elements_correct. + eassumption. + - assumption. +Qed. + +Definition eq_involves (eq : equation) (i : reg) := + i = (eq_lhs eq) \/ In i (eq_args eq). + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. Variable sp : val. - Definition eq_sem (eq : equation) (rs : regset) (m : mem) := + Variable eq_catalog : PTree.t equation. + + Definition sem_eq (eq : equation) (rs : regset) (m : mem) := match eq_op eq with | SOp op => match eval_operation genv sp op (rs ## (eq_args eq)) m with @@ -32,4 +179,10 @@ Section SOUNDNESS. | None => rs # (eq_lhs eq) = default_notrap_load_value chunk end end. + + Definition sem_rel (rel : RELATION.t) (rs : regset) (m : mem) := + forall i eq, + PSet.contains rel i = true -> + PTree.get i eq_catalog = Some eq -> + sem_eq eq rs m. End SOUNDNESS. -- cgit From 3f33a6e366b0c018690c2b3246eb303c5eb57f46 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 17:10:01 +0100 Subject: kill_reg_sound --- backend/CSE3analysis.v | 13 +++++++- backend/CSE3analysisproof.v | 78 +++++++++++++++++++++++++++++++++++++++++++-- lib/HashedSet.v | 2 +- 3 files changed, 89 insertions(+), 4 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 257149b5..485b6067 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -88,7 +88,7 @@ Record equation := eq_op : sym_op; eq_args : list reg }. -Definition eq_id := positive. +Definition eq_id := node. Definition add_i_j (i : reg) (j : eq_id) (m : Regmap.t PSet.t) := Regmap.set i (PSet.add j (Regmap.get i m)) m. @@ -103,4 +103,15 @@ Definition get_kills (eqs : PTree.t equation) : (add_ilist_j (eq_args eq) eqno already)) eqs (PMap.init PSet.empty). +Record eq_context := mkeqcontext + { eq_catalog : node -> option equation; + eq_kills : reg -> PSet.t }. + +Section OPERATIONS. + Context {ctx : eq_context}. + + Definition kill_reg (r : reg) (rel : RELATION.t) : RELATION.t := + PSet.subtract rel (eq_kills ctx r). +End OPERATIONS. + Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index af42a2e8..d3681398 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -9,6 +9,24 @@ Require Import Registers Op RTL. Require Import CSE3analysis CSE2deps CSE2depsproof HashedSet. Require Import Lia. +Lemma subst_args_notin : + forall (rs : regset) dst v args, + ~ In dst args -> + (rs # dst <- v) ## args = rs ## args. +Proof. + induction args; simpl; trivial. + intro NOTIN. + destruct (peq a dst). + { + subst a. + intuition congruence. + } + rewrite Regmap.gso by congruence. + f_equal. + apply IHargs. + intuition congruence. +Qed. + Lemma add_i_j_adds : forall i j m, PSet.contains (Regmap.get i (add_i_j i j m)) j = true. Proof. @@ -159,7 +177,7 @@ Section SOUNDNESS. Variable genv: Genv.t F V. Variable sp : val. - Variable eq_catalog : PTree.t equation. + Context {ctx : eq_context}. Definition sem_eq (eq : equation) (rs : regset) (m : mem) := match eq_op eq with @@ -183,6 +201,62 @@ Section SOUNDNESS. Definition sem_rel (rel : RELATION.t) (rs : regset) (m : mem) := forall i eq, PSet.contains rel i = true -> - PTree.get i eq_catalog = Some eq -> + eq_catalog ctx i = Some eq -> sem_eq eq rs m. + + Hypothesis ctx_kills_has_lhs : + forall lhs sop args j, + eq_catalog ctx j = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + PSet.contains (eq_kills ctx lhs) j = true. + + Hypothesis ctx_kills_has_arg : + forall lhs sop args j, + eq_catalog ctx j = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + forall arg, + In arg args -> + PSet.contains (eq_kills ctx arg) j = true. + + Theorem kill_reg_sound : + forall rel rs m dst v, + (sem_rel rel rs m) -> + (sem_rel (kill_reg (ctx:=ctx) dst rel) (rs#dst <- v) m). + Proof. + unfold sem_rel, sem_eq, kill_reg. + intros until v. + intros REL i eq. + specialize REL with (i := i) (eq0 := eq). + destruct eq as [lhs sop args]; simpl. + specialize ctx_kills_has_lhs with (lhs := lhs) (sop := sop) (args := args) (j := i). + specialize ctx_kills_has_arg with (lhs := lhs) (sop := sop) (args := args) (j := i) (arg := dst). + intuition. + rewrite PSet.gsubtract in H. + rewrite andb_true_iff in H. + rewrite negb_true_iff in H. + intuition. + simpl in *. + assert ({In dst args} + {~In dst args}) as IN_ARGS. + { + apply List.in_dec. + apply peq. + } + destruct IN_ARGS as [IN_ARGS | NOTIN_ARGS]. + { intuition. + congruence. + } + destruct (peq dst lhs). + { + congruence. + } + rewrite subst_args_notin by assumption. + destruct sop. + - destruct (eval_operation genv sp o rs ## args m) as [ev | ]; trivial. + rewrite Regmap.gso by congruence. + assumption. + - rewrite Regmap.gso by congruence. + assumption. + Qed. End SOUNDNESS. diff --git a/lib/HashedSet.v b/lib/HashedSet.v index 5b4faeaa..bd9cd9c0 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -52,7 +52,7 @@ Proof. destruct b; reflexivity. Qed. -Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false: pset. +Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false : pset. Module PSet_internals. Inductive pset : Type := -- cgit From 62d66f9447330ea4f3c31503465c5dee9ed6a0f5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 18:56:30 +0100 Subject: get_moves --- backend/CSE3analysis.v | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 485b6067..f0af0ac7 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -101,7 +101,39 @@ Definition get_kills (eqs : PTree.t equation) : PTree.fold (fun already (eqno : eq_id) (eq : equation) => add_i_j (eq_lhs eq) eqno (add_ilist_j (eq_args eq) eqno already)) eqs - (PMap.init PSet.empty). + (PMap.init PSet.empty). + +Definition is_move (op : operation) : + { op = Omove } + { op <> Omove }. +Proof. + destruct op; try (right ; congruence). + left; trivial. +Qed. + +Definition is_smove (sop : sym_op) : + { sop = SOp Omove } + { sop <> SOp Omove }. +Proof. + destruct sop; try (right ; congruence). + destruct (is_move o). + - left; congruence. + - right; congruence. +Qed. + +Definition get_move (eq : equation) := + if is_smove (eq_op eq) + then match eq_args eq with + | h::nil => Some h + | _ => None + end + else None. + +Definition get_moves (eqs : PTree.t equation) : + Regmap.t PSet.t := + PTree.fold (fun already (eqno : eq_id) (eq : equation) => + match get_move eq with + | Some rhs => add_i_j (eq_lhs eq) rhs already + | None => already + end) eqs (PMap.init PSet.empty). Record eq_context := mkeqcontext { eq_catalog : node -> option equation; -- cgit From ab3f3a52c8737dbad6c599d7afc5720346e00abe Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 19:08:49 +0100 Subject: CSE3 --- backend/CSE3analysisproof.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index d3681398..fde411cf 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -169,6 +169,25 @@ Proof. - assumption. Qed. +Definition xlget_moves (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : + Regmap.t PSet.t := + List.fold_left(fun already eq_id_no => + match get_move (snd eq_id_no) with + | Some rhs => add_i_j (eq_lhs (snd eq_id_no)) rhs already + | None => already + end) eqs m. + +Lemma xlget_moves_monotone: + forall eqs m i j, + PSet.contains (Regmap.get i m) j = true -> + PSet.contains (Regmap.get i (xlget_moves eqs m)) j = true. +Proof. + induction eqs; intros; simpl; trivial. + destruct get_move; auto with cse3. +Qed. + +Hint Resolve xlget_moves_monotone : cse3. + Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). @@ -259,4 +278,6 @@ Section SOUNDNESS. - rewrite Regmap.gso by congruence. assumption. Qed. + + End SOUNDNESS. -- cgit From fc3c1660ee62b5341ccf75505aa63dca0d2cf16c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 21:58:53 +0100 Subject: get moves --- backend/CSE3analysis.v | 15 +++------------ backend/CSE3analysisproof.v | 19 +------------------ 2 files changed, 4 insertions(+), 30 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index f0af0ac7..da527995 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -119,21 +119,12 @@ Proof. - right; congruence. Qed. -Definition get_move (eq : equation) := - if is_smove (eq_op eq) - then match eq_args eq with - | h::nil => Some h - | _ => None - end - else None. - Definition get_moves (eqs : PTree.t equation) : Regmap.t PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => - match get_move eq with - | Some rhs => add_i_j (eq_lhs eq) rhs already - | None => already - end) eqs (PMap.init PSet.empty). + if is_smove (eq_op eq) + then add_i_j (eq_lhs eq) eqno already + else already) eqs (PMap.init PSet.empty). Record eq_context := mkeqcontext { eq_catalog : node -> option equation; diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index fde411cf..29c6618c 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -169,24 +169,7 @@ Proof. - assumption. Qed. -Definition xlget_moves (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : - Regmap.t PSet.t := - List.fold_left(fun already eq_id_no => - match get_move (snd eq_id_no) with - | Some rhs => add_i_j (eq_lhs (snd eq_id_no)) rhs already - | None => already - end) eqs m. - -Lemma xlget_moves_monotone: - forall eqs m i j, - PSet.contains (Regmap.get i m) j = true -> - PSet.contains (Regmap.get i (xlget_moves eqs m)) j = true. -Proof. - induction eqs; intros; simpl; trivial. - destruct get_move; auto with cse3. -Qed. - -Hint Resolve xlget_moves_monotone : cse3. +Hint Resolve get_kills_has_arg : cse3. Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). -- cgit From 5935fa8921d380abd9eef12774ad8ebfcefcf055 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 22:40:19 +0100 Subject: cse3: forward_move_sound --- backend/CSE3analysis.v | 29 ++++++++++++++++++++++++++-- backend/CSE3analysisproof.v | 46 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 72 insertions(+), 3 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index da527995..bbe76f75 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -125,16 +125,41 @@ Definition get_moves (eqs : PTree.t equation) : if is_smove (eq_op eq) then add_i_j (eq_lhs eq) eqno already else already) eqs (PMap.init PSet.empty). - + Record eq_context := mkeqcontext { eq_catalog : node -> option equation; - eq_kills : reg -> PSet.t }. + eq_kills : reg -> PSet.t; + eq_moves : reg -> PSet.t }. Section OPERATIONS. Context {ctx : eq_context}. Definition kill_reg (r : reg) (rel : RELATION.t) : RELATION.t := PSet.subtract rel (eq_kills ctx r). + + Definition pick_source (l : list reg) := (* todo: take min? *) + match l with + | h::t => Some h + | nil => None + end. + + Definition forward_move (rel : RELATION.t) (x : reg) : reg := + match pick_source (PSet.elements (PSet.inter rel (eq_moves ctx x))) with + | None => x + | Some eqno => + match eq_catalog ctx eqno with + | Some eq => + if is_smove (eq_op eq) && peq x (eq_lhs eq) + then + match eq_args eq with + | src::nil => src + | _ => x + end + else x + | _ => x + end + end. + End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 29c6618c..deb8b6e4 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -262,5 +262,49 @@ Section SOUNDNESS. assumption. Qed. - + Lemma pick_source_sound : + forall (l : list reg), + match pick_source l with + | Some x => In x l + | None => True + end. + Proof. + unfold pick_source. + destruct l; simpl; trivial. + left; trivial. + Qed. + + Theorem forward_move_sound : + forall rel rs m x, + (sem_rel rel rs m) -> + rs # (forward_move (ctx := ctx) rel x) = rs # x. + Proof. + unfold sem_rel, forward_move. + intros until x. + intro REL. + pose proof (pick_source_sound (PSet.elements (PSet.inter rel (eq_moves ctx x)))) as ELEMENT. + destruct (pick_source (PSet.elements (PSet.inter rel (eq_moves ctx x)))). + 2: reflexivity. + destruct (eq_catalog ctx r) as [eq | ] eqn:CATALOG. + 2: reflexivity. + specialize REL with (i := r) (eq0 := eq). + destruct (is_smove (eq_op eq)) as [MOVE | ]. + 2: reflexivity. + destruct (peq x (eq_lhs eq)). + 2: reflexivity. + simpl. + subst x. + rewrite PSet.elements_spec in ELEMENT. + rewrite PSet.ginter in ELEMENT. + rewrite andb_true_iff in ELEMENT. + unfold sem_eq in REL. + rewrite MOVE in REL. + simpl in REL. + destruct (eq_args eq) as [ | h t]. + reflexivity. + destruct t. + 2: reflexivity. + simpl in REL. + intuition congruence. + Qed. End SOUNDNESS. -- cgit From 33c7fc589ebbbd0ebda9739c479bbd9ee7e526db Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 9 Mar 2020 23:17:46 +0100 Subject: kill_mem_sound --- backend/CSE3analysisproof.v | 58 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 52 insertions(+), 6 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index deb8b6e4..b14f3964 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -206,21 +206,36 @@ Section SOUNDNESS. eq_catalog ctx i = Some eq -> sem_eq eq rs m. - Hypothesis ctx_kills_has_lhs : + Hypothesis ctx_kill_reg_has_lhs : forall lhs sop args j, eq_catalog ctx j = Some {| eq_lhs := lhs; eq_op := sop; eq_args:= args |} -> - PSet.contains (eq_kills ctx lhs) j = true. + PSet.contains (eq_kill_reg ctx lhs) j = true. - Hypothesis ctx_kills_has_arg : + Hypothesis ctx_kill_reg_has_arg : forall lhs sop args j, eq_catalog ctx j = Some {| eq_lhs := lhs; eq_op := sop; eq_args:= args |} -> forall arg, In arg args -> - PSet.contains (eq_kills ctx arg) j = true. + PSet.contains (eq_kill_reg ctx arg) j = true. + + Hypothesis ctx_kill_mem_has_depends_on_mem : + forall lhs op args j, + eq_catalog ctx j = Some {| eq_lhs := lhs; + eq_op := SOp op; + eq_args:= args |} -> + op_depends_on_memory op = true -> + PSet.contains (eq_kill_mem ctx) j = true. + + Hypothesis ctx_kill_mem_has_load : + forall lhs chunk addr args j, + eq_catalog ctx j = Some {| eq_lhs := lhs; + eq_op := SLoad chunk addr; + eq_args:= args |} -> + PSet.contains (eq_kill_mem ctx) j = true. Theorem kill_reg_sound : forall rel rs m dst v, @@ -232,8 +247,8 @@ Section SOUNDNESS. intros REL i eq. specialize REL with (i := i) (eq0 := eq). destruct eq as [lhs sop args]; simpl. - specialize ctx_kills_has_lhs with (lhs := lhs) (sop := sop) (args := args) (j := i). - specialize ctx_kills_has_arg with (lhs := lhs) (sop := sop) (args := args) (j := i) (arg := dst). + specialize ctx_kill_reg_has_lhs with (lhs := lhs) (sop := sop) (args := args) (j := i). + specialize ctx_kill_reg_has_arg with (lhs := lhs) (sop := sop) (args := args) (j := i) (arg := dst). intuition. rewrite PSet.gsubtract in H. rewrite andb_true_iff in H. @@ -307,4 +322,35 @@ Section SOUNDNESS. simpl in REL. intuition congruence. Qed. + + Theorem kill_mem_sound : + forall rel rs m m', + (sem_rel rel rs m) -> + (sem_rel (kill_mem (ctx:=ctx) rel) rs m'). + Proof. + unfold sem_rel, sem_eq, kill_mem. + intros until m'. + intros REL i eq. + specialize REL with (i := i) (eq0 := eq). + intros SUBTRACT CATALOG. + rewrite PSet.gsubtract in SUBTRACT. + rewrite andb_true_iff in SUBTRACT. + intuition. + destruct (eq_op eq) as [op | chunk addr] eqn:OP. + - specialize ctx_kill_mem_has_depends_on_mem with (lhs := eq_lhs eq) (op := op) (args := eq_args eq) (j := i). + rewrite (op_depends_on_memory_correct genv sp op) with (m2 := m). + assumption. + destruct (op_depends_on_memory op) in *; trivial. + rewrite ctx_kill_mem_has_depends_on_mem in H0; trivial. + discriminate H0. + rewrite <- OP. + rewrite CATALOG. + destruct eq; reflexivity. + - specialize ctx_kill_mem_has_load with (lhs := eq_lhs eq) (chunk := chunk) (addr := addr) (args := eq_args eq) (j := i). + destruct eq as [lhs op args]; simpl in *. + rewrite negb_true_iff in H0. + rewrite OP in CATALOG. + intuition. + congruence. + Qed. End SOUNDNESS. -- cgit From 9cf4ca7760982b40e5721b2d6510eae0ced248a8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 09:11:12 +0100 Subject: forward_move_l --- backend/CSE3analysis.v | 12 +++++++++--- backend/CSE3analysisproof.v | 20 ++++++++++++++++++++ lib/HashedSet.v | 14 +++++++++++++- 3 files changed, 42 insertions(+), 4 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index bbe76f75..c88f06fa 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -128,14 +128,18 @@ Definition get_moves (eqs : PTree.t equation) : Record eq_context := mkeqcontext { eq_catalog : node -> option equation; - eq_kills : reg -> PSet.t; + eq_kill_reg : reg -> PSet.t; + eq_kill_mem : PSet.t; eq_moves : reg -> PSet.t }. Section OPERATIONS. Context {ctx : eq_context}. Definition kill_reg (r : reg) (rel : RELATION.t) : RELATION.t := - PSet.subtract rel (eq_kills ctx r). + PSet.subtract rel (eq_kill_reg ctx r). + + Definition kill_mem (rel : RELATION.t) : RELATION.t := + PSet.subtract rel (eq_kill_mem ctx). Definition pick_source (l : list reg) := (* todo: take min? *) match l with @@ -159,7 +163,9 @@ Section OPERATIONS. | _ => x end end. - + + Definition forward_move_l (rel : RELATION.t) : list reg -> list reg := + List.map (forward_move rel). End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index b14f3964..027a874a 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -277,6 +277,8 @@ Section SOUNDNESS. assumption. Qed. + Hint Resolve kill_reg_sound : cse3. + Lemma pick_source_sound : forall (l : list reg), match pick_source l with @@ -289,6 +291,8 @@ Section SOUNDNESS. left; trivial. Qed. + Hint Resolve pick_source_sound : cse3. + Theorem forward_move_sound : forall rel rs m x, (sem_rel rel rs m) -> @@ -323,6 +327,20 @@ Section SOUNDNESS. intuition congruence. Qed. + Hint Resolve forward_move_sound : cse3. + + Theorem forward_move_l_sound : + forall rel rs m l, + (sem_rel rel rs m) -> + rs ## (forward_move_l (ctx := ctx) rel l) = rs ## l. + Proof. + induction l; simpl; intros; trivial. + erewrite forward_move_sound by eassumption. + intuition congruence. + Qed. + + Hint Resolve forward_move_l_sound : cse3. + Theorem kill_mem_sound : forall rel rs m m', (sem_rel rel rs m) -> @@ -353,4 +371,6 @@ Section SOUNDNESS. intuition. congruence. Qed. + + Hint Resolve kill_mem_sound : cse3. End SOUNDNESS. diff --git a/lib/HashedSet.v b/lib/HashedSet.v index bd9cd9c0..00e01612 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -1058,6 +1058,10 @@ Axiom elements_complete: forall (m: t) (i: positive), In i (elements m) -> contains m i = true. +Axiom elements_spec: + forall (m: t) (i: positive), + In i (elements m) <-> contains m i = true. + Parameter fold: forall {B : Type}, (B -> positive -> B) -> t -> B -> B. @@ -1304,7 +1308,6 @@ Proof. apply PSet_internals.elements_correct. Qed. - Theorem elements_complete: forall (m: pset) (i: positive), In i (elements m) -> contains m i = true. @@ -1314,6 +1317,15 @@ Proof. Qed. +Theorem elements_spec: + forall (m: pset) (i: positive), + In i (elements m) <-> contains m i = true. +Proof. + intros. split. + - apply elements_complete. + - apply elements_correct. +Qed. + Definition fold {B : Type} (f : B -> positive -> B) (m : t) (v : B) : B := PSet_internals.fold f (pset_x m) v. -- cgit From 0892b99d00aac6ad9f7467f1383fe5dc1b45e94f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 09:45:34 +0100 Subject: eq_find_sound --- backend/CSE3analysis.v | 37 ++++++++++++++++++++++++++++++++++++- backend/CSE3analysisproof.v | 16 ++++++++++++++++ 2 files changed, 52 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index c88f06fa..5de4ba80 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -2,6 +2,7 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps CSE2deps. Require Import HashedSet. +Require List. Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. Definition t := PSet.t. @@ -82,12 +83,35 @@ Inductive sym_op : Type := | SOp : operation -> sym_op | SLoad : memory_chunk -> addressing -> sym_op. +Definition eq_dec_sym_op : forall s s' : sym_op, {s = s'} + {s <> s'}. +Proof. + generalize eq_operation. + generalize eq_addressing. + generalize chunk_eq. + decide equality. +Defined. + +Definition eq_dec_args : forall l l' : list reg, { l = l' } + { l <> l' }. +Proof. + apply List.list_eq_dec. + exact peq. +Defined. + Record equation := mkequation { eq_lhs : reg; eq_op : sym_op; eq_args : list reg }. +Definition eq_dec_equation : + forall eq eq' : equation, {eq = eq'} + {eq <> eq'}. +Proof. + generalize peq. + generalize eq_dec_sym_op. + generalize eq_dec_args. + decide equality. +Defined. + Definition eq_id := node. Definition add_i_j (i : reg) (j : eq_id) (m : Regmap.t PSet.t) := @@ -127,7 +151,8 @@ Definition get_moves (eqs : PTree.t equation) : else already) eqs (PMap.init PSet.empty). Record eq_context := mkeqcontext - { eq_catalog : node -> option equation; + { eq_catalog : eq_id -> option equation; + eq_find_oracle : node -> equation -> option eq_id; eq_kill_reg : reg -> PSet.t; eq_kill_mem : PSet.t; eq_moves : reg -> PSet.t }. @@ -166,6 +191,16 @@ Section OPERATIONS. Definition forward_move_l (rel : RELATION.t) : list reg -> list reg := List.map (forward_move rel). + + Definition eq_find (no : node) (eq : equation) := + match eq_find_oracle ctx no eq with + | Some id => + match eq_catalog ctx id with + | Some eq' => if eq_dec_equation eq eq' then Some id else None + | None => None + end + | None => None + end. End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 027a874a..4fa093c6 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -373,4 +373,20 @@ Section SOUNDNESS. Qed. Hint Resolve kill_mem_sound : cse3. + + Theorem eq_find_sound: + forall no eq id, + eq_find (ctx := ctx) no eq = Some id -> + eq_catalog ctx id = Some eq. + Proof. + unfold eq_find. + intros. + destruct (eq_find_oracle ctx no eq) as [ id' | ]. + 2: discriminate. + destruct (eq_catalog ctx id') as [eq' |] eqn:CATALOG. + 2: discriminate. + destruct (eq_dec_equation eq eq'). + 2: discriminate. + congruence. + Qed. End SOUNDNESS. -- cgit From f557bb9d9f264695a94cc598b3027c978eb5aca6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 11:09:37 +0100 Subject: rhs_find_op_sound --- backend/CSE3analysis.v | 15 +++++++++++++ backend/CSE3analysisproof.v | 52 ++++++++++++++++++++++++++++++++++++--------- 2 files changed, 57 insertions(+), 10 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 5de4ba80..41fa67f6 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -153,6 +153,7 @@ Definition get_moves (eqs : PTree.t equation) : Record eq_context := mkeqcontext { eq_catalog : eq_id -> option equation; eq_find_oracle : node -> equation -> option eq_id; + eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t; eq_kill_reg : reg -> PSet.t; eq_kill_mem : PSet.t; eq_moves : reg -> PSet.t }. @@ -201,6 +202,20 @@ Section OPERATIONS. end | None => None end. + + + Definition rhs_find (no : node) (sop : sym_op) (args : list reg) (rel : RELATION.t) : option reg := + match pick_source (PSet.elements (PSet.inter (eq_rhs_oracle ctx no sop args) rel)) with + | None => None + | Some src => + match eq_catalog ctx src with + | None => None + | Some eq => + if eq_dec_sym_op sop (eq_op eq) && eq_dec_args args (eq_args eq) + then Some (eq_lhs eq) + else None + end + end. End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 4fa093c6..b9f4da44 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -180,25 +180,29 @@ Section SOUNDNESS. Variable sp : val. Context {ctx : eq_context}. - - Definition sem_eq (eq : equation) (rs : regset) (m : mem) := - match eq_op eq with + + Definition sem_rhs (sop : sym_op) (args : list reg) + (rs : regset) (m : mem) (v' : val) := + match sop with | SOp op => - match eval_operation genv sp op (rs ## (eq_args eq)) m with - | Some v => rs # (eq_lhs eq) = v + match eval_operation genv sp op (rs ## args) m with + | Some v => v' = v | None => False end | SLoad chunk addr => match - match eval_addressing genv sp addr rs##(eq_args eq) with + match eval_addressing genv sp addr (rs ## args) with | Some a => Mem.loadv chunk m a | None => None end with - | Some dat => rs # (eq_lhs eq) = dat - | None => rs # (eq_lhs eq) = default_notrap_load_value chunk + | Some dat => v' = dat + | None => v' = default_notrap_load_value chunk end end. + + Definition sem_eq (eq : equation) (rs : regset) (m : mem) := + sem_rhs (eq_op eq) (eq_args eq) rs m (rs # (eq_lhs eq)). Definition sem_rel (rel : RELATION.t) (rs : regset) (m : mem) := forall i eq, @@ -242,7 +246,7 @@ Section SOUNDNESS. (sem_rel rel rs m) -> (sem_rel (kill_reg (ctx:=ctx) dst rel) (rs#dst <- v) m). Proof. - unfold sem_rel, sem_eq, kill_reg. + unfold sem_rel, sem_eq, sem_rhs, kill_reg. intros until v. intros REL i eq. specialize REL with (i := i) (eq0 := eq). @@ -346,7 +350,7 @@ Section SOUNDNESS. (sem_rel rel rs m) -> (sem_rel (kill_mem (ctx:=ctx) rel) rs m'). Proof. - unfold sem_rel, sem_eq, kill_mem. + unfold sem_rel, sem_eq, sem_rhs, kill_mem. intros until m'. intros REL i eq. specialize REL with (i := i) (eq0 := eq). @@ -389,4 +393,32 @@ Section SOUNDNESS. 2: discriminate. congruence. Qed. + + Hint Resolve eq_find_sound : cse3. + + Theorem rhs_find_op_sound: + forall no sop args rel src rs m, + sem_rel rel rs m -> + rhs_find (ctx := ctx) no sop args rel = Some src -> + sem_rhs sop args rs m (rs # src). + Proof. + unfold rhs_find, sem_rel, sem_eq. + intros until m. + intros REL FIND. + pose proof (pick_source_sound (PSet.elements (PSet.inter (eq_rhs_oracle ctx no sop args) rel))) as SOURCE. + destruct (pick_source (PSet.elements (PSet.inter (eq_rhs_oracle ctx no sop args) rel))) as [ src' | ]. + 2: discriminate. + rewrite PSet.elements_spec in SOURCE. + rewrite PSet.ginter in SOURCE. + rewrite andb_true_iff in SOURCE. + destruct (eq_catalog ctx src') as [eq | ] eqn:CATALOG. + 2: discriminate. + specialize REL with (i := src') (eq0 := eq). + destruct (eq_dec_sym_op sop (eq_op eq)). + 2: discriminate. + destruct (eq_dec_args args (eq_args eq)). + 2: discriminate. + simpl in FIND. + intuition congruence. + Qed. End SOUNDNESS. -- cgit From b00665af60dc019c75e0f2a64099db163b4c3c26 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 11:18:23 +0100 Subject: forward_move_rhs_sound --- backend/CSE3analysisproof.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index b9f4da44..2b963e39 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -421,4 +421,16 @@ Section SOUNDNESS. simpl in FIND. intuition congruence. Qed. + + Theorem forward_move_rhs_sound : + forall sop args rel rs m v, + (sem_rel rel rs m) -> + (sem_rhs sop args rs m v) -> + (sem_rhs sop (forward_move_l (ctx := ctx) rel args) rs m v). + Proof. + intros until v. + intros REL RHS. + destruct sop; simpl in *. + all: erewrite forward_move_l_sound by eassumption; assumption. + Qed. End SOUNDNESS. -- cgit From c2319ee007eba06f92837e1e370dfa5e58b06b82 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 14:57:24 +0100 Subject: oper2 --- backend/CSE3analysis.v | 12 ++++- backend/CSE3analysisproof.v | 121 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 131 insertions(+), 2 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 41fa67f6..456898cf 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -216,6 +216,16 @@ Section OPERATIONS. else None end end. -End OPERATIONS. + + Definition oper2 (no : node) (dst : reg) (op: sym_op)(args : list reg) + (rel : RELATION.t) := + let rel' := kill_reg dst rel in + match eq_find no {| eq_lhs := dst; + eq_op := op; + eq_args:= args |} with + | Some id => PSet.add id rel' + | None => rel' + end. + End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 2b963e39..e2ce6b5d 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -282,7 +282,26 @@ Section SOUNDNESS. Qed. Hint Resolve kill_reg_sound : cse3. - + + Theorem kill_reg_sound2 : + forall rel rs m dst, + (sem_rel rel rs m) -> + (sem_rel (kill_reg (ctx:=ctx) dst rel) rs m). + Proof. + unfold sem_rel, sem_eq, sem_rhs, kill_reg. + intros until dst. + intros REL i eq. + specialize REL with (i := i) (eq0 := eq). + destruct eq as [lhs sop args]; simpl. + specialize ctx_kill_reg_has_lhs with (lhs := lhs) (sop := sop) (args := args) (j := i). + specialize ctx_kill_reg_has_arg with (lhs := lhs) (sop := sop) (args := args) (j := i) (arg := dst). + intuition. + rewrite PSet.gsubtract in H. + rewrite andb_true_iff in H. + rewrite negb_true_iff in H. + intuition. + Qed. + Lemma pick_source_sound : forall (l : list reg), match pick_source l with @@ -421,6 +440,8 @@ Section SOUNDNESS. simpl in FIND. intuition congruence. Qed. + + Hint Resolve rhs_find_op_sound : cse3. Theorem forward_move_rhs_sound : forall sop args rel rs m v, @@ -433,4 +454,102 @@ Section SOUNDNESS. destruct sop; simpl in *. all: erewrite forward_move_l_sound by eassumption; assumption. Qed. + + Hint Resolve forward_move_rhs_sound : cse3. + + Lemma arg_not_replaced: + forall (rs : regset) dst v args, + ~ In dst args -> + (rs # dst <- v) ## args = rs ## args. + Proof. + induction args; simpl; trivial. + intuition. + f_equal; trivial. + apply Regmap.gso; congruence. + Qed. + + Lemma sem_rhs_depends_on_args_only: + forall sop args rs dst m v, + sem_rhs sop args rs m v -> + ~ In dst args -> + sem_rhs sop args (rs # dst <- v) m v. + Proof. + unfold sem_rhs. + intros. + rewrite arg_not_replaced by assumption. + assumption. + Qed. + + Lemma replace_sound: + forall no eqno dst sop args rel rs m v, + sem_rel rel rs m -> + sem_rhs sop args rs m v -> + ~ In dst args -> + eq_find (ctx := ctx) + no {| eq_lhs := dst; + eq_op := sop; + eq_args:= args |} = Some eqno -> + sem_rel (PSet.add eqno (kill_reg (ctx := ctx) dst rel)) (rs # dst <- v) m. + Proof. + intros until v. + intros REL RHS NOTIN FIND i eq CONTAINS CATALOG. + destruct (peq i eqno). + - subst i. + rewrite eq_find_sound with (no := no) (eq0 := {| eq_lhs := dst; eq_op := sop; eq_args := args |}) in CATALOG by exact FIND. + clear FIND. + inv CATALOG. + unfold sem_eq. + simpl in *. + rewrite Regmap.gss. + apply sem_rhs_depends_on_args_only; auto. + - rewrite PSet.gaddo in CONTAINS by congruence. + eapply kill_reg_sound; eauto. + Qed. + + Lemma sem_rhs_det: + forall sop args rs m v v', + sem_rhs sop args rs m v -> + sem_rhs sop args rs m v' -> + v = v'. + Proof. + intros until v'. intro SEMv. + destruct sop; simpl in *. + - destruct eval_operation. + congruence. + contradiction. + - destruct eval_addressing. + + destruct Mem.loadv; congruence. + + congruence. + Qed. + + Theorem oper2_sound: + forall no dst sop args rel rs m v, + sem_rel rel rs m -> + not (In dst args) -> + sem_rhs sop args rs m v -> + sem_rel (oper2 (ctx := ctx) no dst sop args rel) (rs # dst <- v) m. + Proof. + unfold oper2. + intros until v. + intros REL NOTIN RHS. + pose proof (eq_find_sound no {| eq_lhs := dst; eq_op := sop; eq_args := args |}) as EQ_FIND_SOUND. + destruct eq_find. + 2: auto with cse3; fail. + specialize EQ_FIND_SOUND with (id := e). + intuition. + intros i eq CONTAINS. + destruct (peq i e). + { subst i. + rewrite H. + clear H. + intro Z. + inv Z. + unfold sem_eq. + simpl. + rewrite Regmap.gss. + apply sem_rhs_depends_on_args_only; auto. + } + rewrite PSet.gaddo in CONTAINS by congruence. + apply (kill_reg_sound rel rs m dst v REL i eq); auto. + Qed. End SOUNDNESS. -- cgit From 11dc19dc169d99a944abb4144ea67eb4fc03f883 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 15:06:12 +0100 Subject: moved no away --- backend/CSE3analysis.v | 27 +++++++++++++++++++-------- backend/CSE3analysisproof.v | 8 ++++---- 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 456898cf..7357a811 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -193,7 +193,10 @@ Section OPERATIONS. Definition forward_move_l (rel : RELATION.t) : list reg -> list reg := List.map (forward_move rel). - Definition eq_find (no : node) (eq : equation) := + Section PER_NODE. + Variable no : node. + + Definition eq_find (eq : equation) := match eq_find_oracle ctx no eq with | Some id => match eq_catalog ctx id with @@ -204,7 +207,7 @@ Section OPERATIONS. end. - Definition rhs_find (no : node) (sop : sym_op) (args : list reg) (rel : RELATION.t) : option reg := + Definition rhs_find (sop : sym_op) (args : list reg) (rel : RELATION.t) : option reg := match pick_source (PSet.elements (PSet.inter (eq_rhs_oracle ctx no sop args) rel)) with | None => None | Some src => @@ -217,15 +220,23 @@ Section OPERATIONS. end end. - Definition oper2 (no : node) (dst : reg) (op: sym_op)(args : list reg) - (rel : RELATION.t) := + Definition oper2 (dst : reg) (op: sym_op)(args : list reg) + (rel : RELATION.t) : RELATION.t := let rel' := kill_reg dst rel in - match eq_find no {| eq_lhs := dst; - eq_op := op; - eq_args:= args |} with + match eq_find {| eq_lhs := dst; + eq_op := op; + eq_args:= args |} with | Some id => PSet.add id rel' | None => rel' end. - End OPERATIONS. + + Definition oper1 (dst : reg) (op: sym_op) (args : list reg) + (rel : RELATION.t) : RELATION.t := + if List.in_dec peq dst args + then kill_reg dst rel + else oper2 dst op args rel. + + End PER_NODE. +End OPERATIONS. Definition totoro := RELATION.lub. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index e2ce6b5d..a1e57eb5 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -485,10 +485,10 @@ Section SOUNDNESS. sem_rel rel rs m -> sem_rhs sop args rs m v -> ~ In dst args -> - eq_find (ctx := ctx) - no {| eq_lhs := dst; - eq_op := sop; - eq_args:= args |} = Some eqno -> + eq_find (ctx := ctx) no + {| eq_lhs := dst; + eq_op := sop; + eq_args:= args |} = Some eqno -> sem_rel (PSet.add eqno (kill_reg (ctx := ctx) dst rel)) (rs # dst <- v) m. Proof. intros until v. -- cgit From d5bbfed2c8a0a208cf365abb1df249c9d91ff8e4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 15:08:16 +0100 Subject: oper1 --- backend/CSE3analysisproof.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index a1e57eb5..5eff5e08 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -552,4 +552,18 @@ Section SOUNDNESS. rewrite PSet.gaddo in CONTAINS by congruence. apply (kill_reg_sound rel rs m dst v REL i eq); auto. Qed. + + Hint Resolve oper2_sound : cse3. + + Theorem oper1_sound: + forall no dst sop args rel rs m v, + sem_rel rel rs m -> + sem_rhs sop args rs m v -> + sem_rel (oper1 (ctx := ctx) no dst sop args rel) (rs # dst <- v) m. + Proof. + intros. + unfold oper1. + destruct in_dec; auto with cse3. + Qed. + End SOUNDNESS. -- cgit From 8c8e6a0528a91420e399ae84ccf293c0d8be285f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 15:30:57 +0100 Subject: move sound --- backend/CSE3analysis.v | 17 +++++++++++++++++ backend/CSE3analysisproof.v | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 7357a811..cdda2cb7 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -236,6 +236,23 @@ Section OPERATIONS. then kill_reg dst rel else oper2 dst op args rel. + + Definition move (src dst : reg) (rel : RELATION.t) : RELATION.t := + match eq_find {| eq_lhs := dst; + eq_op := SOp Omove; + eq_args:= src::nil |} with + | Some eq_id => PSet.add eq_id (kill_reg dst rel) + | None => kill_reg dst rel + end. + + (* + Definition oper (dst : reg) (op: sym_op) (args : list reg) + (rel : RELATION.t) : RELATION.t := + match find_op rel op (forward_move_l rel args) with + | Some r => move r dst rel + | None => oper1 op dst args rel + end. +*) End PER_NODE. End OPERATIONS. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 5eff5e08..96baac77 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -565,5 +565,37 @@ Section SOUNDNESS. unfold oper1. destruct in_dec; auto with cse3. Qed. - + + Lemma move_sound : + forall no : node, + forall rel : RELATION.t, + forall src dst : reg, + forall rs m, + sem_rel rel rs m -> + sem_rel (move (ctx:=ctx) no src dst rel) (rs # dst <- (rs # src)) m. + Proof. + unfold move. + intros until m. + intro REL. + pose proof (eq_find_sound no {| eq_lhs := dst; eq_op := SOp Omove; eq_args := src :: nil |}) as EQ_FIND_SOUND. + destruct eq_find. + - intros i eq CONTAINS. + destruct (peq i e). + + subst i. + rewrite (EQ_FIND_SOUND e) by trivial. + intro Z. + inv Z. + unfold sem_eq. + simpl. + destruct (peq src dst). + * subst dst. + reflexivity. + * rewrite Regmap.gss. + rewrite Regmap.gso by congruence. + reflexivity. + + intros. + rewrite PSet.gaddo in CONTAINS by congruence. + apply (kill_reg_sound rel rs m dst (rs # src) REL i); auto. + - apply kill_reg_sound; auto. + Qed. End SOUNDNESS. -- cgit From b7bf754fce5e9442c3a5b1e5cec25ed522d0e870 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 15:50:50 +0100 Subject: oper sound --- backend/CSE3analysis.v | 7 +++---- backend/CSE3analysisproof.v | 30 +++++++++++++++++++++++++++--- 2 files changed, 30 insertions(+), 7 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index cdda2cb7..6cce52c7 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -245,14 +245,13 @@ Section OPERATIONS. | None => kill_reg dst rel end. - (* Definition oper (dst : reg) (op: sym_op) (args : list reg) (rel : RELATION.t) : RELATION.t := - match find_op rel op (forward_move_l rel args) with + match rhs_find op (forward_move_l rel args) rel with | Some r => move r dst rel - | None => oper1 op dst args rel + | None => oper1 dst op args rel end. -*) + End PER_NODE. End OPERATIONS. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 96baac77..c0a9be48 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -415,7 +415,7 @@ Section SOUNDNESS. Hint Resolve eq_find_sound : cse3. - Theorem rhs_find_op_sound: + Theorem rhs_find_sound: forall no sop args rel src rs m, sem_rel rel rs m -> rhs_find (ctx := ctx) no sop args rel = Some src -> @@ -441,7 +441,7 @@ Section SOUNDNESS. intuition congruence. Qed. - Hint Resolve rhs_find_op_sound : cse3. + Hint Resolve rhs_find_sound : cse3. Theorem forward_move_rhs_sound : forall sop args rel rs m v, @@ -507,7 +507,7 @@ Section SOUNDNESS. Qed. Lemma sem_rhs_det: - forall sop args rs m v v', + forall {sop} {args} {rs} {m} {v} {v'}, sem_rhs sop args rs m v -> sem_rhs sop args rs m v' -> v = v'. @@ -566,6 +566,8 @@ Section SOUNDNESS. destruct in_dec; auto with cse3. Qed. + Hint Resolve oper1_sound : cse3. + Lemma move_sound : forall no : node, forall rel : RELATION.t, @@ -598,4 +600,26 @@ Section SOUNDNESS. apply (kill_reg_sound rel rs m dst (rs # src) REL i); auto. - apply kill_reg_sound; auto. Qed. + + Hint Resolve move_sound : cse3. + + Theorem oper_sound: + forall no dst sop args rel rs m v, + sem_rel rel rs m -> + sem_rhs sop args rs m v -> + sem_rel (oper (ctx := ctx) no dst sop args rel) (rs # dst <- v) m. + Proof. + intros until v. + intros REL RHS. + unfold oper. + destruct rhs_find as [src |] eqn:RHS_FIND. + - pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. + eapply forward_move_rhs_sound in RHS. + 2: eassumption. + rewrite <- (sem_rhs_det SOUND RHS). + apply move_sound; auto. + - apply oper1_sound; auto. + Qed. + + Hint Resolve oper_sound : cse3. End SOUNDNESS. -- cgit From 76c887ad132aa7b0c7ac72dca5d56e4c2bf1747a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 15:56:05 +0100 Subject: CSE3: apply_instr' --- backend/CSE3analysis.v | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 6cce52c7..966d3fd1 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -74,6 +74,8 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. rewrite andb_true_iff. intuition. Qed. + + Definition top := PSet.empty. End RELATION. Module RB := ADD_BOTTOM(RELATION). @@ -253,6 +255,34 @@ Section OPERATIONS. end. End PER_NODE. + +Definition apply_instr no instr (rel : RELATION.t) : RB.t := + match instr with + | Inop _ + | Icond _ _ _ _ + | Ijumptable _ _ => Some rel + | Istore chunk addr args _ _ => Some (kill_mem rel) + | Iop op args dst _ => Some (oper no dst (SOp op) args rel) + | Iload trap chunk addr args dst _ => Some (oper no dst (SLoad chunk addr) args rel) + | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) + | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) + | Itailcall _ _ _ | Ireturn _ => RB.bot + end. + +Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := + match ro with + | None => None + | Some x => + match code ! pc with + | None => RB.bot + | Some instr => apply_instr pc instr x + end + end. + +Definition forward_map (f : RTL.function) := DS.fixpoint + (RTL.fn_code f) RTL.successors_instr + (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). + End OPERATIONS. Definition totoro := RELATION.lub. -- cgit From 59413cb4018d09fb3b641a49ab062bc933d5274c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 19:56:30 +0100 Subject: starts compiling but still fake --- Makefile | 2 +- backend/CSE3.v | 27 +++++++++ backend/CSE3analysis.v | 39 +++++++++++-- backend/CSE3analysisaux.ml | 36 ++++++++++++ backend/CSE3analysisproof.v | 12 ++-- backend/CSE3proof.v | 138 ++++++++++++++++++++++++++++++++++++++++++++ driver/Clflags.ml | 1 + driver/Compiler.v | 26 ++++++--- driver/Compopts.v | 3 + extraction/extraction.v | 9 ++- 10 files changed, 270 insertions(+), 23 deletions(-) create mode 100644 backend/CSE3.v create mode 100644 backend/CSE3analysisaux.ml create mode 100644 backend/CSE3proof.v diff --git a/Makefile b/Makefile index dc368c66..623cbad4 100644 --- a/Makefile +++ b/Makefile @@ -89,7 +89,7 @@ BACKEND=\ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ - CSE3analysis.v \ + CSE3analysis.v CSE3analysisproof.v CSE3.v CSE3proof.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ diff --git a/backend/CSE3.v b/backend/CSE3.v new file mode 100644 index 00000000..f4d75c51 --- /dev/null +++ b/backend/CSE3.v @@ -0,0 +1,27 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps CSE2deps. +Require Import CSE3analysis HashedSet. + +Axiom preanalysis : RTL.function -> analysis_hints. + +Definition run f := preanalysis f. + +Definition transf_instr (fmap : analysis_hints) + (pc: node) (instr: instruction) := instr. + +Definition transf_function (f: function) : function := + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.map (transf_instr (preanalysis f)) f.(fn_code); + fn_entrypoint := f.(fn_entrypoint) |}. + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. + +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 966d3fd1..ded31270 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -122,13 +122,25 @@ Definition add_i_j (i : reg) (j : eq_id) (m : Regmap.t PSet.t) := Definition add_ilist_j (ilist : list reg) (j : eq_id) (m : Regmap.t PSet.t) := List.fold_left (fun already i => add_i_j i j already) ilist m. -Definition get_kills (eqs : PTree.t equation) : +Definition get_reg_kills (eqs : PTree.t equation) : Regmap.t PSet.t := PTree.fold (fun already (eqno : eq_id) (eq : equation) => add_i_j (eq_lhs eq) eqno (add_ilist_j (eq_args eq) eqno already)) eqs (PMap.init PSet.empty). +Definition eq_depends_on_mem eq := + match eq_op eq with + | SLoad _ _ => true + | SOp op => op_depends_on_memory op + end. + +Definition get_mem_kills (eqs : PTree.t equation) : PSet.t := + PTree.fold (fun already (eqno : eq_id) (eq : equation) => + if eq_depends_on_mem eq + then PSet.add eqno already + else already) eqs PSet.empty. + Definition is_move (op : operation) : { op = Omove } + { op <> Omove }. Proof. @@ -157,7 +169,7 @@ Record eq_context := mkeqcontext eq_find_oracle : node -> equation -> option eq_id; eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t; eq_kill_reg : reg -> PSet.t; - eq_kill_mem : PSet.t; + eq_kill_mem : unit -> PSet.t; eq_moves : reg -> PSet.t }. Section OPERATIONS. @@ -167,7 +179,7 @@ Section OPERATIONS. PSet.subtract rel (eq_kill_reg ctx r). Definition kill_mem (rel : RELATION.t) : RELATION.t := - PSet.subtract rel (eq_kill_mem ctx). + PSet.subtract rel (eq_kill_mem ctx tt). Definition pick_source (l : list reg) := (* todo: take min? *) match l with @@ -279,10 +291,27 @@ Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := end end. -Definition forward_map (f : RTL.function) := DS.fixpoint +Definition internal_analysis (f : RTL.function) := DS.fixpoint (RTL.fn_code f) RTL.successors_instr (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). End OPERATIONS. -Definition totoro := RELATION.lub. +Record analysis_hints := + mkanalysis_hints + { hint_eq_catalog : PTree.t equation; + hint_eq_find_oracle : node -> equation -> option eq_id; + hint_eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t }. + +Definition analysis (eqs : PTree.t equation) (hints : analysis_hints) := + let reg_kills := get_reg_kills eqs in + let mem_kills := get_mem_kills eqs in + let moves := get_moves eqs in + internal_analysis (ctx := {| + eq_catalog := fun eq_id => PTree.get eq_id (hint_eq_catalog hints); + eq_find_oracle := hint_eq_find_oracle hints ; + eq_rhs_oracle := hint_eq_rhs_oracle hints; + eq_kill_reg := fun reg => PMap.get reg reg_kills; + eq_kill_mem := fun _ => mem_kills; + eq_moves := fun reg => PMap.get reg moves + |}). diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml new file mode 100644 index 00000000..26f19fd6 --- /dev/null +++ b/backend/CSE3analysisaux.ml @@ -0,0 +1,36 @@ +open CSE3analysis +open Maps +open HashedSet +open Camlcoq + +let flatten_eq eq = + ((P.to_int eq.eq_lhs), eq.eq_op, List.map P.to_int eq.eq_args);; + +let preanalysis (f : RTL.coq_function) = + let cur_eq_id = ref 0 + and cur_catalog = ref PTree.empty + and eq_table = Hashtbl.create 100 + and rhs_table = Hashtbl.create 100 + and cur_kill_reg = ref (PMap.init PSet.empty) + and cur_kill_mem = ref PSet.empty + and cur_moves = ref (PMap.init PSet.empty) in + let eq_find_oracle node eq = + Hashtbl.find_opt eq_table (flatten_eq eq) + and rhs_find_oracle node sop args = + match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with + | None -> PSet.empty + | Some s -> s in + let mutating_eq_find_oracle node eq = + incr cur_eq_id; None in (* FIXME *) + ignore + (internal_analysis + { eq_catalog = (fun eq_id -> PTree.get eq_id !cur_catalog); + eq_find_oracle = mutating_eq_find_oracle; + eq_rhs_oracle = rhs_find_oracle ; + eq_kill_reg = (fun reg -> PMap.get reg !cur_kill_reg); + eq_kill_mem = (fun () -> !cur_kill_mem); + eq_moves = (fun reg -> PMap.get reg !cur_moves) + } f); + { hint_eq_catalog = !cur_catalog; + hint_eq_find_oracle= eq_find_oracle; + hint_eq_rhs_oracle = rhs_find_oracle };; diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index c0a9be48..f805d2b8 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -134,9 +134,9 @@ Lemma get_kills_has_lhs : PTree.get j eqs = Some {| eq_lhs := lhs; eq_op := sop; eq_args:= args |} -> - PSet.contains (Regmap.get lhs (get_kills eqs)) j = true. + PSet.contains (Regmap.get lhs (get_reg_kills eqs)) j = true. Proof. - unfold get_kills. + unfold get_reg_kills. intros. rewrite PTree.fold_spec. change (fold_left @@ -154,9 +154,9 @@ Lemma get_kills_has_arg : eq_op := sop; eq_args:= args |} -> In arg args -> - PSet.contains (Regmap.get arg (get_kills eqs)) j = true. + PSet.contains (Regmap.get arg (get_reg_kills eqs)) j = true. Proof. - unfold get_kills. + unfold get_reg_kills. intros. rewrite PTree.fold_spec. change (fold_left @@ -232,14 +232,14 @@ Section SOUNDNESS. eq_op := SOp op; eq_args:= args |} -> op_depends_on_memory op = true -> - PSet.contains (eq_kill_mem ctx) j = true. + PSet.contains (eq_kill_mem ctx tt) j = true. Hypothesis ctx_kill_mem_has_load : forall lhs chunk addr args j, eq_catalog ctx j = Some {| eq_lhs := lhs; eq_op := SLoad chunk addr; eq_args:= args |} -> - PSet.contains (eq_kill_mem ctx) j = true. + PSet.contains (eq_kill_mem ctx tt) j = true. Theorem kill_reg_sound : forall rel rs m dst v, diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v new file mode 100644 index 00000000..408b3cee --- /dev/null +++ b/backend/CSE3proof.v @@ -0,0 +1,138 @@ +(* +Replace available expressions by the register containing their value. + +Proofs. + +David Monniaux, CNRS, VERIMAG + *) + +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE3 CSE3analysis CSE3analysisproof. + + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. +End SOUNDNESS. + + +Definition match_prog (p tp: RTL.program) := + match_program (fun cu f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. apply match_transform_program; auto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (Genv.find_funct_transf TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. +Proof. + destruct f; trivial. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + unfold find_function; intros. destruct ros as [r|id]. + eapply functions_translated; eauto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. +Qed. + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := +| match_frames_intro: forall res f sp pc rs, + (* (forall m : mem, + forall vres, (fmap_sem' sp m (forward_map f) pc rs # res <- vres)) -> *) + match_frames (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). + +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk'), + (* (fmap_sem' sp m (forward_map f) pc rs) -> *) + match_states (State stk f sp pc rs m) + (State stk' (transf_function f) sp pc rs m) + | match_callstates: forall stk f args m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Callstate stk f args m) + (Callstate stk' (transf_fundef f) args m) + | match_returnstates: forall stk v m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Returnstate stk v m) + (Returnstate stk' v m). + + +Lemma step_simulation: + forall S1 t S2, RTL.step ge S1 t S2 -> + forall S1', match_states S1 S1' -> + exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. +Proof. +Admitted. +Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. +Proof. + intros. inv H. econstructor; split. + econstructor. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. + eapply function_ptr_translated; eauto. + rewrite <- H3; apply sig_preserved. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. +Proof. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + eapply forward_simulation_step. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 6d6f1df4..f4022941 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -27,6 +27,7 @@ let option_ftailcalls = ref true let option_fconstprop = ref true let option_fcse = ref true let option_fcse2 = ref true +let option_fcse3 = ref true let option_fredundancy = ref true let option_fduplicate = ref false let option_finvertcond = ref true (* only active if option_fduplicate is also true *) diff --git a/driver/Compiler.v b/driver/Compiler.v index a641587c..22955160 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -43,7 +43,7 @@ Require Constprop. Require CSE. Require ForwardMoves. Require CSE2. -Require CSE3analysis. +Require CSE3. Require Deadcode. Require Unusedglob. Require Allnontrap. @@ -69,6 +69,7 @@ Require Constpropproof. Require CSEproof. Require ForwardMovesproof. Require CSE2proof. +Require CSE3proof. Require Deadcodeproof. Require Unusedglobproof. Require Allnontrapproof. @@ -145,14 +146,16 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 7) @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 8) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program + @@ total_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) @@ print (print_RTL 9) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 10) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 11) - @@@ time "Unused globals" Unusedglob.transform_program + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program @@ print (print_RTL 12) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 13) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -260,6 +263,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE3 CSE3proof.match_prog) ::: mkpass (match_if Compopts.optim_forward_moves ForwardMovesproof.match_prog) ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog) @@ -307,8 +311,9 @@ Proof. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - set (p13ter := total_if optim_forward_moves ForwardMoves.transf_program p13bis) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13ter) as [p14|e] eqn:P14; simpl in T; try discriminate. + set (p13ter := total_if optim_CSE3 CSE3.transf_program p13bis) in *. + set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. + destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. @@ -332,7 +337,8 @@ Proof. exists p12; split. apply total_if_match. apply Renumberproof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. - exists p13ter; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. + exists p13ter; split. apply total_if_match. apply CSE3proof.transf_program_match. + exists p13quater; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match. exists p15; split. apply Unusedglobproof.transf_program_match; auto. @@ -393,7 +399,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p25)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p26)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -423,6 +429,8 @@ Ltac DestructM := eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact CSE2proof.transf_program_correct. eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact CSE3proof.transf_program_correct. + eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact ForwardMovesproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. diff --git a/driver/Compopts.v b/driver/Compopts.v index b4b9f30d..1f952164 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -43,6 +43,9 @@ Parameter optim_CSE: unit -> bool. (** Flag -fcse2. For DMonniaux's common subexpression elimination. *) Parameter optim_CSE2: unit -> bool. +(** Flag -fcse3. For DMonniaux's common subexpression elimination. *) +Parameter optim_CSE3: unit -> bool. + (** Flag -fredundancy. For dead code elimination. *) Parameter optim_redundancy: unit -> bool. diff --git a/extraction/extraction.v b/extraction/extraction.v index ea30e7c2..61c7c746 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -36,7 +36,8 @@ Require Parser. Require Initializers. Require Asmaux. -Require CSE3analysis. (* FIXME *) +Require CSE3. +Require CSE3analysis. (* Standard lib *) Require Import ExtrOcamlBasic. @@ -115,6 +116,8 @@ Extract Constant Compopts.optim_CSE => "fun _ -> !Clflags.option_fcse". Extract Constant Compopts.optim_CSE2 => "fun _ -> !Clflags.option_fcse2". +Extract Constant Compopts.optim_CSE3 => + "fun _ -> !Clflags.option_fcse3". Extract Constant Compopts.optim_redundancy => "fun _ -> !Clflags.option_fredundancy". Extract Constant Compopts.optim_postpass => @@ -162,6 +165,8 @@ Extract Constant Cabs.loc => Extract Inlined Constant Cabs.string => "String.t". Extract Constant Cabs.char_code => "int64". +Extract Inlined Constant CSE3.preanalysis => "CSE3analysisaux.preanalysis". + Extract Inductive HashedSet.PSet_internals.pset => "HashedSetaux.pset" [ "HashedSetaux.empty" "HashedSetaux.node" ] "HashedSetaux.pset_match". Extract Inlined Constant HashedSet.PSet_internals.pset_eq => "(==)" (* "HashedSetaux.eq" *). @@ -188,7 +193,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction - CSE3analysis.totoro (* FIXME *) + CSE3analysis.internal_analysis CSE3.run Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env -- cgit From e3e33a26c5ddb7c7747da67aa36fd56d0386f3c8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 20:50:25 +0100 Subject: printing created hashes --- backend/CSE3analysisaux.ml | 56 ++++++++++++++++++++++++++++++++++++++++++++-- extraction/extraction.v | 2 +- 2 files changed, 55 insertions(+), 3 deletions(-) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 26f19fd6..8229a76d 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -6,6 +6,33 @@ open Camlcoq let flatten_eq eq = ((P.to_int eq.eq_lhs), eq.eq_op, List.map P.to_int eq.eq_args);; +let imp_add_i_j s i j = + s := PMap.set i (PSet.add j (PMap.get i !s)) !s;; + +let string_of_chunk = function + | AST.Mint8signed -> "int8signed" + | AST.Mint8unsigned -> "int8unsigned" + | AST.Mint16signed -> "int16signed" + | AST.Mint16unsigned -> "int16unsigned" + | AST.Mint32 -> "int32" + | AST.Mint64 -> "int64" + | AST.Mfloat32 -> "float32" + | AST.Mfloat64 -> "float64" + | AST.Many32 -> "any32" + | AST.Many64 -> "any64";; + +let print_reg channel i = + Printf.fprintf channel "r%d" i;; + +let print_eq channel id (lhs, sop, args) = + Printf.printf "%d: " id; + match sop with + | SOp op -> + Printf.printf "%a = %a\n" print_reg lhs (PrintOp.print_operation print_reg) (op, args) + | SLoad(chunk, addr) -> + Printf.printf "%a = %s @ %a\n" print_reg lhs (string_of_chunk chunk) + (PrintOp.print_addressing print_reg) (addr, args);; + let preanalysis (f : RTL.coq_function) = let cur_eq_id = ref 0 and cur_catalog = ref PTree.empty @@ -20,8 +47,33 @@ let preanalysis (f : RTL.coq_function) = match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with | None -> PSet.empty | Some s -> s in - let mutating_eq_find_oracle node eq = - incr cur_eq_id; None in (* FIXME *) + let mutating_eq_find_oracle node eq : P.t option = + let (flat_eq_lhs, flat_eq_op, flat_eq_args) as flat_eq = flatten_eq eq in + match Hashtbl.find_opt eq_table flat_eq with + | Some x -> Some x + | None -> + incr cur_eq_id; + let id = !cur_eq_id in + let coq_id = P.of_int id in + begin + print_eq stderr id flat_eq; + Hashtbl.add eq_table flat_eq coq_id; + Hashtbl.add rhs_table (flat_eq_op, flat_eq_args) + (PSet.add coq_id + (match Hashtbl.find_opt rhs_table (flat_eq_op, flat_eq_args) with + | None -> PSet.empty + | Some s -> s)); + List.iter + (fun reg -> imp_add_i_j cur_kill_reg reg coq_id) + (eq.eq_lhs :: eq.eq_args); + (if eq_depends_on_mem eq + then cur_kill_mem := PSet.add coq_id !cur_kill_mem); + (match eq.eq_op, eq.eq_args with + | (SOp Op.Omove), [rhs] -> imp_add_i_j cur_moves eq.eq_lhs coq_id + | _, _ -> ()); + Some coq_id + end + in ignore (internal_analysis { eq_catalog = (fun eq_id -> PTree.get eq_id !cur_catalog); diff --git a/extraction/extraction.v b/extraction/extraction.v index 61c7c746..bf51da42 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -193,7 +193,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction - CSE3analysis.internal_analysis CSE3.run + CSE3analysis.internal_analysis CSE3analysis.eq_depends_on_mem CSE3.run Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env -- cgit From d47f93b0f7ced7ae02cfeb8827886ac65e06817d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 21:35:25 +0100 Subject: -fcse3 command line option --- backend/CSE3analysisaux.ml | 8 ++++---- driver/Driver.ml | 4 +++- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 8229a76d..2e7d7063 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -24,8 +24,7 @@ let string_of_chunk = function let print_reg channel i = Printf.fprintf channel "r%d" i;; -let print_eq channel id (lhs, sop, args) = - Printf.printf "%d: " id; +let print_eq channel (lhs, sop, args) = match sop with | SOp op -> Printf.printf "%a = %a\n" print_reg lhs (PrintOp.print_operation print_reg) (op, args) @@ -50,13 +49,14 @@ let preanalysis (f : RTL.coq_function) = let mutating_eq_find_oracle node eq : P.t option = let (flat_eq_lhs, flat_eq_op, flat_eq_args) as flat_eq = flatten_eq eq in match Hashtbl.find_opt eq_table flat_eq with - | Some x -> Some x + | Some x -> + Some x | None -> + (* FIXME print_eq stderr flat_eq; *) incr cur_eq_id; let id = !cur_eq_id in let coq_id = P.of_int id in begin - print_eq stderr id flat_eq; Hashtbl.add eq_table flat_eq coq_id; Hashtbl.add rhs_table (flat_eq_op, flat_eq_args) (PSet.add coq_id diff --git a/driver/Driver.ml b/driver/Driver.ml index db71aef9..6f32fc33 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -196,6 +196,7 @@ Processing options: (=0: none, =1: limited, =2: full; default is full) -fcse Perform common subexpression elimination [on] -fcse2 Perform inter-loop common subexpression elimination [on] + -fcse3 Perform inter-loop common subexpression elimination [on] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] @@ -265,7 +266,7 @@ let dump_mnemonics destfile = let optimization_options = [ option_ftailcalls; option_fifconversion; option_fconstprop; - option_fcse; option_fcse2; + option_fcse; option_fcse2; option_fcse3; option_fpostpass; option_fredundancy; option_finline; option_finline_functions_called_once; ] @@ -391,6 +392,7 @@ let cmdline_actions = @ f_opt "const-prop" option_fconstprop @ f_opt "cse" option_fcse @ f_opt "cse2" option_fcse2 + @ f_opt "cse3" option_fcse3 @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass @ f_opt "duplicate" option_fduplicate -- cgit From 4dc9118a4578be8b869a8dd8fa98c15a0b592419 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 10 Mar 2020 22:04:04 +0100 Subject: progress on CSE3 --- backend/CSE3.v | 4 ++-- backend/CSE3analysis.v | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index f4d75c51..386591f1 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -7,14 +7,14 @@ Axiom preanalysis : RTL.function -> analysis_hints. Definition run f := preanalysis f. -Definition transf_instr (fmap : analysis_hints) +Definition transf_instr (fmap : option (PMap.t RB.t)) (pc: node) (instr: instruction) := instr. Definition transf_function (f: function) : function := {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); fn_stacksize := f.(fn_stacksize); - fn_code := PTree.map (transf_instr (preanalysis f)) f.(fn_code); + fn_code := PTree.map (transf_instr (analysis (preanalysis f) f)) f.(fn_code); fn_entrypoint := f.(fn_entrypoint) |}. Definition transf_fundef (fd: fundef) : fundef := diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index ded31270..140f2333 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -303,12 +303,13 @@ Record analysis_hints := hint_eq_find_oracle : node -> equation -> option eq_id; hint_eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t }. -Definition analysis (eqs : PTree.t equation) (hints : analysis_hints) := +Definition analysis (hints : analysis_hints) := + let eqs := hint_eq_catalog hints in let reg_kills := get_reg_kills eqs in let mem_kills := get_mem_kills eqs in let moves := get_moves eqs in internal_analysis (ctx := {| - eq_catalog := fun eq_id => PTree.get eq_id (hint_eq_catalog hints); + eq_catalog := fun eq_id => PTree.get eq_id eqs; eq_find_oracle := hint_eq_find_oracle hints ; eq_rhs_oracle := hint_eq_rhs_oracle hints; eq_kill_reg := fun reg => PMap.get reg reg_kills; -- cgit From 2231fe82a807cebab5cae495ed08cda17810efdc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Mar 2020 11:57:30 +0100 Subject: CSE3 ready to run? --- backend/CSE3.v | 71 ++++++++++++++++++++++++++++++++++++++++++++++++-- backend/CSE3analysis.v | 18 ++++++------- 2 files changed, 78 insertions(+), 11 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index 386591f1..d67a7a87 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -7,14 +7,81 @@ Axiom preanalysis : RTL.function -> analysis_hints. Definition run f := preanalysis f. +Section REWRITE. + Context {ctx : eq_context}. + +Definition find_op_in_fmap fmap pc op args := + match fmap with + | None => None + | Some map => + match PMap.get pc map with + | Some rel => rhs_find (ctx:=ctx) pc (SOp op) args rel + | None => None + end + end. + +Definition find_load_in_fmap fmap pc chunk addr args := + match fmap with + | None => None + | Some map => + match PMap.get pc map with + | Some rel => rhs_find (ctx:=ctx) pc (SLoad chunk addr) args rel + | None => None + end + end. + +Definition forward_move_b (rb : RB.t) (x : reg) := + match rb with + | None => x + | Some rel => forward_move (ctx := ctx) rel x + end. + +Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := + match fmap with + | None => x + | Some inv => forward_move_b (PMap.get pc inv) x + end. + +Definition subst_args fmap pc := List.map (subst_arg fmap pc). + Definition transf_instr (fmap : option (PMap.t RB.t)) - (pc: node) (instr: instruction) := instr. + (pc: node) (instr: instruction) := + match instr with + | Iop op args dst s => + let args' := subst_args fmap pc args in + match find_op_in_fmap fmap pc op args' with + | None => Iop op args' dst s + | Some src => Iop Omove (src::nil) dst s + end + | Iload trap chunk addr args dst s => + let args' := subst_args fmap pc args in + match find_load_in_fmap fmap pc chunk addr args' with + | None => Iload trap chunk addr args' dst s + | Some src => Iop Omove (src::nil) dst s + end + | Istore chunk addr args src s => + Istore chunk addr (subst_args fmap pc args) src s + | Icall sig ros args dst s => + Icall sig ros (subst_args fmap pc args) dst s + | Itailcall sig ros args => + Itailcall sig ros (subst_args fmap pc args) + | Icond cond args s1 s2 => + Icond cond (subst_args fmap pc args) s1 s2 + | Ijumptable arg tbl => + Ijumptable (subst_arg fmap pc arg) tbl + | Ireturn (Some arg) => + Ireturn (Some (subst_arg fmap pc arg)) + | _ => instr + end. +End REWRITE. Definition transf_function (f: function) : function := + let ctx := context_from_hints (preanalysis f) in + let invariants := internal_analysis (ctx := ctx) f in {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); fn_stacksize := f.(fn_stacksize); - fn_code := PTree.map (transf_instr (analysis (preanalysis f) f)) f.(fn_code); + fn_code := PTree.map (transf_instr (ctx := ctx) invariants) f.(fn_code); fn_entrypoint := f.(fn_entrypoint) |}. Definition transf_fundef (fd: fundef) : fundef := diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 140f2333..18aa33b1 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -303,16 +303,16 @@ Record analysis_hints := hint_eq_find_oracle : node -> equation -> option eq_id; hint_eq_rhs_oracle : node -> sym_op -> list reg -> PSet.t }. -Definition analysis (hints : analysis_hints) := +Definition context_from_hints (hints : analysis_hints) := let eqs := hint_eq_catalog hints in let reg_kills := get_reg_kills eqs in let mem_kills := get_mem_kills eqs in let moves := get_moves eqs in - internal_analysis (ctx := {| - eq_catalog := fun eq_id => PTree.get eq_id eqs; - eq_find_oracle := hint_eq_find_oracle hints ; - eq_rhs_oracle := hint_eq_rhs_oracle hints; - eq_kill_reg := fun reg => PMap.get reg reg_kills; - eq_kill_mem := fun _ => mem_kills; - eq_moves := fun reg => PMap.get reg moves - |}). + {| + eq_catalog := fun eq_id => PTree.get eq_id eqs; + eq_find_oracle := hint_eq_find_oracle hints ; + eq_rhs_oracle := hint_eq_rhs_oracle hints; + eq_kill_reg := fun reg => PMap.get reg reg_kills; + eq_kill_mem := fun _ => mem_kills; + eq_moves := fun reg => PMap.get reg moves + |}. -- cgit From ca1536a5d9e850cf9c86a70f421412d2c7bdff38 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 11 Mar 2020 12:55:40 +0100 Subject: fix in catalog handling --- backend/CSE3analysisaux.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 2e7d7063..f3c7d9b9 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -32,6 +32,11 @@ let print_eq channel (lhs, sop, args) = Printf.printf "%a = %s @ %a\n" print_reg lhs (string_of_chunk chunk) (PrintOp.print_addressing print_reg) (addr, args);; +let print_set s = + Printf.printf "{ "; + List.iter (fun i -> Printf.printf "%d; " (P.to_int i)) (PSet.elements s); + Printf.printf "}\n";; + let preanalysis (f : RTL.coq_function) = let cur_eq_id = ref 0 and cur_catalog = ref PTree.empty @@ -52,12 +57,13 @@ let preanalysis (f : RTL.coq_function) = | Some x -> Some x | None -> - (* FIXME print_eq stderr flat_eq; *) + (* TODO print_eq stderr flat_eq; *) incr cur_eq_id; let id = !cur_eq_id in let coq_id = P.of_int id in begin Hashtbl.add eq_table flat_eq coq_id; + (cur_catalog := PTree.set coq_id eq !cur_catalog); Hashtbl.add rhs_table (flat_eq_op, flat_eq_args) (PSet.add coq_id (match Hashtbl.find_opt rhs_table (flat_eq_op, flat_eq_args) with -- cgit From ee3bc59771eb50a8e39dc1db21e5439ce992e630 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 10:39:52 +0100 Subject: lemmas on storev --- backend/CSE3analysis.v | 27 +++++++++++++++++++++++++++ backend/CSE3analysisproof.v | 34 ++++++++++++++++++++++++++++++++++ 2 files changed, 61 insertions(+) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 18aa33b1..2d559413 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -4,6 +4,16 @@ Require Import Memory Registers Op RTL Maps CSE2deps. Require Import HashedSet. Require List. +Definition loadv_storev_compatible_type + (chunk : memory_chunk) (ty : typ) : bool := + match chunk, ty with + | Mint32, Tint + | Mint64, Tlong + | Mfloat32, Tsingle + | Mfloat64, Tfloat => true + | _, _ => false + end. + Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. Definition t := PSet.t. Definition eq (x : t) (y : t) := x = y. @@ -266,6 +276,23 @@ Section OPERATIONS. | None => oper1 dst op args rel end. + Definition store2 + (chunk : memory_chunk) (addr: addressing) (args : list reg) + (src : reg) + (rel : RELATION.t) : RELATION.t := kill_mem rel. + + Definition store1 + (chunk : memory_chunk) (addr: addressing) (args : list reg) + (src : reg) (ty: typ) + (rel : RELATION.t) : RELATION.t := + let rel' := store2 chunk addr args src rel in + match eq_find {| eq_lhs := src; + eq_op := SLoad chunk addr; + eq_args:= args |} with + | Some id => PSet.add id rel' + | None => rel' + end. + End PER_NODE. Definition apply_instr no instr (rel : RELATION.t) : RB.t := diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index f805d2b8..7ef44c22 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -9,6 +9,26 @@ Require Import Registers Op RTL. Require Import CSE3analysis CSE2deps CSE2depsproof HashedSet. Require Import Lia. +Theorem loadv_storev_really_same: + forall chunk: memory_chunk, + forall m1: mem, + forall addr v: val, + forall m2: mem, + forall ty : typ, + forall TYPE: Val.has_type v ty, + forall STORE: Mem.storev chunk m1 addr v = Some m2, + forall COMPATIBLE: loadv_storev_compatible_type chunk ty = true, + Mem.loadv chunk m2 addr = Some v. +Proof. + intros. + rewrite Mem.loadv_storev_same with (m1:=m1) (v:=v) by assumption. + f_equal. + destruct chunk; destruct ty; try discriminate. + all: destruct v; trivial; try contradiction. + all: unfold Val.load_result, Val.has_type in *. + all: destruct Archi.ptr64; trivial; discriminate. +Qed. + Lemma subst_args_notin : forall (rs : regset) dst v args, ~ In dst args -> @@ -622,4 +642,18 @@ Section SOUNDNESS. Qed. Hint Resolve oper_sound : cse3. + + Theorem store2_sound: + forall chunk addr args a src rel rs m m' v, + sem_rel rel rs m -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.storev chunk m a v = Some m' -> + sem_rel (store2 (ctx:=ctx) chunk addr args src rel) rs m'. + Proof. + unfold store2. + intros. + apply kill_mem_sound with (m:=m); auto. + Qed. + + Hint Resolve store2_sound : cse3. End SOUNDNESS. -- cgit From a3be6358778bb02b03b62486a60b9fd9ef1f1c04 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 11:37:59 +0100 Subject: more lemmas --- backend/CSE3analysis.v | 15 +++++++++------ backend/CSE3analysisproof.v | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 45 insertions(+), 8 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 2d559413..a85cd493 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -286,12 +286,15 @@ Section OPERATIONS. (src : reg) (ty: typ) (rel : RELATION.t) : RELATION.t := let rel' := store2 chunk addr args src rel in - match eq_find {| eq_lhs := src; - eq_op := SLoad chunk addr; - eq_args:= args |} with - | Some id => PSet.add id rel' - | None => rel' - end. + if loadv_storev_compatible_type chunk ty + then + match eq_find {| eq_lhs := src; + eq_op := SLoad chunk addr; + eq_args:= args |} with + | Some id => PSet.add id rel' + | None => rel' + end + else rel'. End PER_NODE. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 7ef44c22..f5dd7bf9 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -7,6 +7,7 @@ Require Import Globalenvs Values. Require Import Linking Values Memory Globalenvs Events Smallstep. Require Import Registers Op RTL. Require Import CSE3analysis CSE2deps CSE2depsproof HashedSet. +Require Import RTLtyping. Require Import Lia. Theorem loadv_storev_really_same: @@ -644,10 +645,10 @@ Section SOUNDNESS. Hint Resolve oper_sound : cse3. Theorem store2_sound: - forall chunk addr args a src rel rs m m' v, + forall chunk addr args a src rel rs m m', sem_rel rel rs m -> eval_addressing genv sp addr (rs ## args) = Some a -> - Mem.storev chunk m a v = Some m' -> + Mem.storev chunk m a (rs # src) = Some m' -> sem_rel (store2 (ctx:=ctx) chunk addr args src rel) rs m'. Proof. unfold store2. @@ -656,4 +657,37 @@ Section SOUNDNESS. Qed. Hint Resolve store2_sound : cse3. + + Theorem store1_sound: + forall no chunk addr args a src rel tenv rs m m', + sem_rel rel rs m -> + wt_regset tenv rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.storev chunk m a (rs#src) = Some m' -> + sem_rel (store1 (ctx:=ctx) no chunk addr args src (tenv src) rel) rs m'. + Proof. + unfold store1. + intros until m'. + intros REL WT ADDR STORE. + assert (sem_rel (store2 (ctx:=ctx) chunk addr args src rel) rs m') as REL' by eauto with cse3. + destruct loadv_storev_compatible_type eqn:COMPATIBLE. + 2: auto; fail. + destruct eq_find as [eq_id | ] eqn:FIND. + 2: auto; fail. + intros i eq CONTAINS CATALOG. + destruct (peq i eq_id). + { subst i. + rewrite eq_find_sound with (no:=no) (eq0:={| eq_lhs := src; eq_op := SLoad chunk addr; eq_args := args |}) in CATALOG; trivial. + inv CATALOG. + unfold sem_eq. + simpl. + rewrite ADDR. + rewrite loadv_storev_really_same with (m1:=m) (v:=rs#src) (ty:=(tenv src)); trivial. + } + unfold sem_rel in REL'. + rewrite PSet.gaddo in CONTAINS by congruence. + eauto. + Qed. + + Hint Resolve store2_sound : cse3. End SOUNDNESS. -- cgit From 935dcae6384e718d26d29377e4c50e53151809e4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 12:41:28 +0100 Subject: store sound --- backend/CSE3analysis.v | 5 +++++ backend/CSE3analysisproof.v | 20 +++++++++++++++++++- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index a85cd493..300bb216 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -296,6 +296,11 @@ Section OPERATIONS. end else rel'. + Definition store + (chunk : memory_chunk) (addr: addressing) (args : list reg) + (src : reg) (ty: typ) + (rel : RELATION.t) : RELATION.t := + store1 chunk addr (forward_move_l rel args) src ty rel. End PER_NODE. Definition apply_instr no instr (rel : RELATION.t) : RB.t := diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index f5dd7bf9..05c7a8f3 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -689,5 +689,23 @@ Section SOUNDNESS. eauto. Qed. - Hint Resolve store2_sound : cse3. + Hint Resolve store1_sound : cse3. + + Theorem store_sound: + forall no chunk addr args a src rel tenv rs m m', + sem_rel rel rs m -> + wt_regset tenv rs -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.storev chunk m a (rs#src) = Some m' -> + sem_rel (store (ctx:=ctx) no chunk addr args src (tenv src) rel) rs m'. + Proof. + unfold store. + intros until m'. + intros REL WT ADDR STORE. + rewrite <- forward_move_l_sound with (rel:=rel) (m:=m) in ADDR by trivial. + rewrite <- forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. + apply store1_sound with (a := a) (m := m); trivial. + rewrite forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. + assumption. + Qed. End SOUNDNESS. -- cgit From f1327f4d4e2fb15c6032959375cdc36ffe20167f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 14:11:39 +0100 Subject: typing and store stuff --- backend/CSE3.v | 34 +++++++++-------- backend/CSE3analysis.v | 23 +++++++----- backend/CSE3analysisaux.ml | 4 +- backend/CSE3proof.v | 91 +++++++++++++++++++++++++++++----------------- driver/Compiler.v | 6 +-- 5 files changed, 94 insertions(+), 64 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index d67a7a87..2ef16376 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -2,8 +2,11 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps CSE2deps. Require Import CSE3analysis HashedSet. +Require Import RTLtyping. -Axiom preanalysis : RTL.function -> analysis_hints. +Local Open Scope error_monad_scope. + +Axiom preanalysis : typing_env -> RTL.function -> analysis_hints. Definition run f := preanalysis f. @@ -75,20 +78,19 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) end. End REWRITE. -Definition transf_function (f: function) : function := - let ctx := context_from_hints (preanalysis f) in - let invariants := internal_analysis (ctx := ctx) f in - {| fn_sig := f.(fn_sig); - fn_params := f.(fn_params); - fn_stacksize := f.(fn_stacksize); - fn_code := PTree.map (transf_instr (ctx := ctx) invariants) f.(fn_code); - fn_entrypoint := f.(fn_entrypoint) |}. - -Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef transf_function fd. +Definition transf_function (f: function) : res function := + do tenv <- type_function f; + let ctx := context_from_hints (preanalysis tenv f) in + let invariants := internal_analysis (ctx := ctx) tenv f in + OK {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.map (transf_instr (ctx := ctx) invariants) + f.(fn_code); + fn_entrypoint := f.(fn_entrypoint) |}. -Definition transf_program (p: program) : program := - transform_program transf_fundef p. +Definition transf_fundef (fd: fundef) : res fundef := + AST.transf_partial_fundef transf_function fd. -Definition match_prog (p tp: RTL.program) := - match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 300bb216..643b752a 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -4,6 +4,8 @@ Require Import Memory Registers Op RTL Maps CSE2deps. Require Import HashedSet. Require List. +Definition typing_env := reg -> typ. + Definition loadv_storev_compatible_type (chunk : memory_chunk) (ty : typ) : bool := match chunk, ty with @@ -301,34 +303,37 @@ Section OPERATIONS. (src : reg) (ty: typ) (rel : RELATION.t) : RELATION.t := store1 chunk addr (forward_move_l rel args) src ty rel. - End PER_NODE. -Definition apply_instr no instr (rel : RELATION.t) : RB.t := +Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := match instr with | Inop _ | Icond _ _ _ _ | Ijumptable _ _ => Some rel - | Istore chunk addr args _ _ => Some (kill_mem rel) - | Iop op args dst _ => Some (oper no dst (SOp op) args rel) - | Iload trap chunk addr args dst _ => Some (oper no dst (SLoad chunk addr) args rel) + | Istore chunk addr args src _ => + Some (store chunk addr args src (tenv src) rel) + | Iop op args dst _ => Some (oper dst (SOp op) args rel) + | Iload trap chunk addr args dst _ => Some (oper dst (SLoad chunk addr) args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) | Itailcall _ _ _ | Ireturn _ => RB.bot end. + End PER_NODE. -Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t := +Definition apply_instr' (tenv : typing_env) code (pc : node) (ro : RB.t) : RB.t := match ro with | None => None | Some x => match code ! pc with | None => RB.bot - | Some instr => apply_instr pc instr x + | Some instr => apply_instr pc tenv instr x end end. -Definition internal_analysis (f : RTL.function) := DS.fixpoint +Definition internal_analysis + (tenv : typing_env) + (f : RTL.function) := DS.fixpoint (RTL.fn_code f) RTL.successors_instr - (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). + (apply_instr' tenv (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). End OPERATIONS. diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index f3c7d9b9..392fd13f 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -37,7 +37,7 @@ let print_set s = List.iter (fun i -> Printf.printf "%d; " (P.to_int i)) (PSet.elements s); Printf.printf "}\n";; -let preanalysis (f : RTL.coq_function) = +let preanalysis (tenv : typing_env) (f : RTL.coq_function) = let cur_eq_id = ref 0 and cur_catalog = ref PTree.empty and eq_table = Hashtbl.create 100 @@ -88,7 +88,7 @@ let preanalysis (f : RTL.coq_function) = eq_kill_reg = (fun reg -> PMap.get reg !cur_kill_reg); eq_kill_mem = (fun () -> !cur_kill_mem); eq_moves = (fun reg -> PMap.get reg !cur_moves) - } f); + } tenv f); { hint_eq_catalog = !cur_catalog; hint_eq_find_oracle= eq_find_oracle; hint_eq_rhs_oracle = rhs_find_oracle };; diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 408b3cee..c7a882b6 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -24,52 +24,68 @@ End SOUNDNESS. Definition match_prog (p tp: RTL.program) := - match_program (fun cu f tf => tf = transf_fundef f) eq p tp. + match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. Lemma transf_program_match: - forall p, match_prog p (transf_program p). + forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. - intros. apply match_transform_program; auto. + intros. eapply match_transform_partial_program; eauto. Qed. Section PRESERVATION. Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma functions_translated: - forall v f, + forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). -Proof (Genv.find_funct_transf TRANSL). + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof. + apply (Genv.find_funct_transf_partial TRANSF). +Qed. Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> - Genv.find_funct_ptr tge v = Some (transf_fundef f). -Proof (Genv.find_funct_ptr_transf TRANSL). + forall (b: block) (f: RTL.fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof. + apply (Genv.find_funct_ptr_transf_partial TRANSF). +Qed. Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_transf TRANSL). +Proof. + apply (Genv.find_symbol_match TRANSF). +Qed. Lemma senv_preserved: Senv.equiv ge tge. -Proof (Genv.senv_transf TRANSL). +Proof. + apply (Genv.senv_match TRANSF). +Qed. Lemma sig_preserved: - forall f, funsig (transf_fundef f) = funsig f. + forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f. Proof. - destruct f; trivial. + destruct f; simpl; intros. + - monadInv H. + monadInv EQ. + reflexivity. + - monadInv H. + reflexivity. Qed. Lemma find_function_translated: forall ros rs fd, - find_function ge ros rs = Some fd -> - find_function tge ros rs = Some (transf_fundef fd). + find_function ge ros rs = Some fd -> + exists tfd, + find_function tge ros rs = Some tfd /\ transf_fundef fd = OK tfd. Proof. unfold find_function; intros. destruct ros as [r|id]. eapply functions_translated; eauto. @@ -78,27 +94,29 @@ Proof. Qed. Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := -| match_frames_intro: forall res f sp pc rs, +| match_frames_intro: forall res f tf sp pc rs + (FUN : transf_function f = OK tf), (* (forall m : mem, forall vres, (fmap_sem' sp m (forward_map f) pc rs # res <- vres)) -> *) match_frames (Stackframe res f sp pc rs) - (Stackframe res (transf_function f) sp pc rs). + (Stackframe res tf sp pc rs). Inductive match_states: RTL.state -> RTL.state -> Prop := - | match_regular_states: forall stk f sp pc rs m stk' - (STACKS: list_forall2 match_frames stk stk'), + | match_regular_states: forall stk tf f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk') + (FUN: transf_function f = OK tf), (* (fmap_sem' sp m (forward_map f) pc rs) -> *) match_states (State stk f sp pc rs m) - (State stk' (transf_function f) sp pc rs m) - | match_callstates: forall stk f args m stk' - (STACKS: list_forall2 match_frames stk stk'), + (State stk' tf sp pc rs m) + | match_callstates: forall stk f tf args m stk' + (STACKS: list_forall2 match_frames stk stk') + (FUN: transf_fundef f = OK tf), match_states (Callstate stk f args m) - (Callstate stk' (transf_fundef f) args m) + (Callstate stk' tf args m) | match_returnstates: forall stk v m stk' (STACKS: list_forall2 match_frames stk stk'), match_states (Returnstate stk v m) - (Returnstate stk' v m). - + (Returnstate stk' v m). Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> @@ -106,17 +124,22 @@ Lemma step_simulation: exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. Proof. Admitted. + Lemma transf_initial_states: forall S1, RTL.initial_state prog S1 -> exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. Proof. - intros. inv H. econstructor; split. - econstructor. - eapply (Genv.init_mem_transf TRANSL); eauto. - rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. - eapply function_ptr_translated; eauto. - rewrite <- H3; apply sig_preserved. - constructor. constructor. + intros. inversion H. + exploit function_ptr_translated; eauto. + intros (tf & A & B). + exists (Callstate nil tf nil m0); split. + - econstructor; eauto. + + eapply (Genv.init_mem_match TRANSF); eauto. + + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + symmetry. eapply match_program_main; eauto. + + rewrite <- H3. eapply sig_preserved; eauto. + - econstructor; auto. constructor. Qed. Lemma transf_final_states: diff --git a/driver/Compiler.v b/driver/Compiler.v index c2428d94..47fb8236 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -146,7 +146,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 7) @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 8) - @@ total_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) + @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) @@ print (print_RTL 9) @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 10) @@ -311,7 +311,7 @@ Proof. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - set (p13ter := total_if optim_CSE3 CSE3.transf_program p13bis) in *. + destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. @@ -337,7 +337,7 @@ Proof. exists p12; split. apply total_if_match. apply Renumberproof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. - exists p13ter; split. apply total_if_match. apply CSE3proof.transf_program_match. + exists p13ter; split. eapply partial_if_match; eauto. apply CSE3proof.transf_program_match. exists p13quater; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match. -- cgit From 9efb4d87c549087e2ef16103a6993a1f99328348 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 14:16:13 +0100 Subject: storeload example --- test/monniaux/cse2/storeload.c | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test/monniaux/cse2/storeload.c diff --git a/test/monniaux/cse2/storeload.c b/test/monniaux/cse2/storeload.c new file mode 100644 index 00000000..3fa5b226 --- /dev/null +++ b/test/monniaux/cse2/storeload.c @@ -0,0 +1,4 @@ +int toto(int *p, int x) { + *p = x; + return *p; +} -- cgit From c6ebd73465ef895c6ea5e240f9c784463a6a0fe5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 16:46:06 +0100 Subject: removed second analysis phase --- backend/CSE3.v | 33 ++++++++++----------------------- backend/CSE3analysis.v | 4 +++- backend/CSE3analysisaux.ml | 15 +++++++++------ backend/CSE3proof.v | 2 ++ extraction/extraction.v | 2 +- 5 files changed, 25 insertions(+), 31 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index 2ef16376..e82b7cdb 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -6,31 +6,21 @@ Require Import RTLtyping. Local Open Scope error_monad_scope. -Axiom preanalysis : typing_env -> RTL.function -> analysis_hints. - -Definition run f := preanalysis f. +Axiom preanalysis : typing_env -> RTL.function -> invariants * analysis_hints. Section REWRITE. Context {ctx : eq_context}. Definition find_op_in_fmap fmap pc op args := - match fmap with + match PMap.get pc fmap with + | Some rel => rhs_find (ctx:=ctx) pc (SOp op) args rel | None => None - | Some map => - match PMap.get pc map with - | Some rel => rhs_find (ctx:=ctx) pc (SOp op) args rel - | None => None - end end. Definition find_load_in_fmap fmap pc chunk addr args := - match fmap with + match PMap.get pc fmap with + | Some rel => rhs_find (ctx:=ctx) pc (SLoad chunk addr) args rel | None => None - | Some map => - match PMap.get pc map with - | Some rel => rhs_find (ctx:=ctx) pc (SLoad chunk addr) args rel - | None => None - end end. Definition forward_move_b (rb : RB.t) (x : reg) := @@ -39,15 +29,12 @@ Definition forward_move_b (rb : RB.t) (x : reg) := | Some rel => forward_move (ctx := ctx) rel x end. -Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg := - match fmap with - | None => x - | Some inv => forward_move_b (PMap.get pc inv) x - end. +Definition subst_arg (fmap : PMap.t RB.t) (pc : node) (x : reg) : reg := + forward_move_b (PMap.get pc fmap) x. Definition subst_args fmap pc := List.map (subst_arg fmap pc). -Definition transf_instr (fmap : option (PMap.t RB.t)) +Definition transf_instr (fmap : PMap.t RB.t) (pc: node) (instr: instruction) := match instr with | Iop op args dst s => @@ -80,8 +67,8 @@ End REWRITE. Definition transf_function (f: function) : res function := do tenv <- type_function f; - let ctx := context_from_hints (preanalysis tenv f) in - let invariants := internal_analysis (ctx := ctx) tenv f in + let (invariants, hints) := preanalysis tenv f in + let ctx := context_from_hints hints in OK {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); fn_stacksize := f.(fn_stacksize); diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 643b752a..69c21113 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -329,9 +329,11 @@ Definition apply_instr' (tenv : typing_env) code (pc : node) (ro : RB.t) : RB.t end end. +Definition invariants := PMap.t RB.t. + Definition internal_analysis (tenv : typing_env) - (f : RTL.function) := DS.fixpoint + (f : RTL.function) : option invariants := DS.fixpoint (RTL.fn_code f) RTL.successors_instr (apply_instr' tenv (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top). diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 392fd13f..23e20ea8 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -80,15 +80,18 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = Some coq_id end in - ignore - (internal_analysis + match + internal_analysis { eq_catalog = (fun eq_id -> PTree.get eq_id !cur_catalog); eq_find_oracle = mutating_eq_find_oracle; eq_rhs_oracle = rhs_find_oracle ; eq_kill_reg = (fun reg -> PMap.get reg !cur_kill_reg); eq_kill_mem = (fun () -> !cur_kill_mem); eq_moves = (fun reg -> PMap.get reg !cur_moves) - } tenv f); - { hint_eq_catalog = !cur_catalog; - hint_eq_find_oracle= eq_find_oracle; - hint_eq_rhs_oracle = rhs_find_oracle };; + } tenv f + with None -> failwith "CSE3analysisaux analysis failed, try re-running with -fno-cse3" + | Some invariants -> + invariants, + { hint_eq_catalog = !cur_catalog; + hint_eq_find_oracle= eq_find_oracle; + hint_eq_rhs_oracle = rhs_find_oracle };; diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index c7a882b6..72b3e7e1 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -76,6 +76,8 @@ Proof. destruct f; simpl; intros. - monadInv H. monadInv EQ. + destruct preanalysis. + inv EQ1. reflexivity. - monadInv H. reflexivity. diff --git a/extraction/extraction.v b/extraction/extraction.v index 79393cf8..9b47b203 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -191,7 +191,7 @@ Set Extraction AccessOpaque. Cd "extraction". Separate Extraction - CSE3analysis.internal_analysis CSE3analysis.eq_depends_on_mem CSE3.run + CSE3analysis.internal_analysis CSE3analysis.eq_depends_on_mem Compiler.transf_c_program Compiler.transf_cminor_program Cexec.do_initial_state Cexec.do_step Cexec.at_final_state Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env -- cgit From 560c9837eee2145e3a9763aa2e37a6eb34c7e9ac Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 17:21:31 +0100 Subject: inductiveness test in CSE3 --- backend/CSE3.v | 7 +++++-- backend/CSE3analysis.v | 24 +++++++++++++++++++++++- backend/CSE3proof.v | 4 +++- 3 files changed, 31 insertions(+), 4 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index e82b7cdb..d54b9ffa 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -67,14 +67,17 @@ End REWRITE. Definition transf_function (f: function) : res function := do tenv <- type_function f; - let (invariants, hints) := preanalysis tenv f in + let (invariants, hints) := preanalysis tenv f in let ctx := context_from_hints hints in + if check_inductiveness (ctx:=ctx) tenv invariants f + then OK {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); fn_stacksize := f.(fn_stacksize); fn_code := PTree.map (transf_instr (ctx := ctx) invariants) f.(fn_code); - fn_entrypoint := f.(fn_entrypoint) |}. + fn_entrypoint := f.(fn_entrypoint) |} + else Error (msg "cse3: not inductive"). Definition transf_fundef (fd: fundef) : res fundef := AST.transf_partial_fundef transf_function fd. diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 69c21113..43c44ccd 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -304,7 +304,7 @@ Section OPERATIONS. (rel : RELATION.t) : RELATION.t := store1 chunk addr (forward_move_l rel args) src ty rel. -Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := + Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := match instr with | Inop _ | Icond _ _ _ _ @@ -331,6 +331,28 @@ Definition apply_instr' (tenv : typing_env) code (pc : node) (ro : RB.t) : RB.t Definition invariants := PMap.t RB.t. +Definition rel_le (x y : RELATION.t) : bool := (PSet.is_subset y x). + +Definition relb_le (x y : RB.t) : bool := + match x, y with + | None, _ => true + | (Some _), None => false + | (Some x), (Some y) => rel_le x y + end. + +Definition check_inductiveness (tenv: typing_env) (inv: invariants) (fn : RTL.function) := + (RB.beq (Some RELATION.top) (PMap.get (fn_entrypoint fn) inv)) && + PTree_Properties.for_all (fn_code fn) + (fun pc instr => + match PMap.get pc inv with + | None => true + | Some rel => + let rel' := apply_instr pc tenv instr rel in + List.forallb + (fun pc' => relb_le rel' (PMap.get pc' inv)) + (RTL.successors_instr instr) + end). + Definition internal_analysis (tenv : typing_env) (f : RTL.function) : option invariants := DS.fixpoint diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 72b3e7e1..e277a3e1 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -76,7 +76,9 @@ Proof. destruct f; simpl; intros. - monadInv H. monadInv EQ. - destruct preanalysis. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. inv EQ1. reflexivity. - monadInv H. -- cgit From 7ead22b0a04fbea3fb0ef99ba3528460f0d6bd67 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 19:31:42 +0100 Subject: CSE3 analysis --- backend/CSE3.v | 2 +- backend/CSE3analysis.v | 10 +++--- backend/CSE3analysisproof.v | 75 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 81 insertions(+), 6 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index d54b9ffa..f8a25515 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -69,7 +69,7 @@ Definition transf_function (f: function) : res function := do tenv <- type_function f; let (invariants, hints) := preanalysis tenv f in let ctx := context_from_hints hints in - if check_inductiveness (ctx:=ctx) tenv invariants f + if check_inductiveness (ctx:=ctx) f tenv invariants then OK {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 43c44ccd..76723f40 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -331,16 +331,16 @@ Definition apply_instr' (tenv : typing_env) code (pc : node) (ro : RB.t) : RB.t Definition invariants := PMap.t RB.t. -Definition rel_le (x y : RELATION.t) : bool := (PSet.is_subset y x). +Definition rel_leb (x y : RELATION.t) : bool := (PSet.is_subset y x). -Definition relb_le (x y : RB.t) : bool := +Definition relb_leb (x y : RB.t) : bool := match x, y with | None, _ => true | (Some _), None => false - | (Some x), (Some y) => rel_le x y + | (Some x), (Some y) => rel_leb x y end. -Definition check_inductiveness (tenv: typing_env) (inv: invariants) (fn : RTL.function) := +Definition check_inductiveness (fn : RTL.function) (tenv: typing_env) (inv: invariants) := (RB.beq (Some RELATION.top) (PMap.get (fn_entrypoint fn) inv)) && PTree_Properties.for_all (fn_code fn) (fun pc instr => @@ -349,7 +349,7 @@ Definition check_inductiveness (tenv: typing_env) (inv: invariants) (fn : RTL.fu | Some rel => let rel' := apply_instr pc tenv instr rel in List.forallb - (fun pc' => relb_le rel' (PMap.get pc' inv)) + (fun pc' => relb_leb rel' (PMap.get pc' inv)) (RTL.successors_instr instr) end). diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 05c7a8f3..5514c532 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -10,6 +10,26 @@ Require Import CSE3analysis CSE2deps CSE2depsproof HashedSet. Require Import RTLtyping. Require Import Lia. +Lemma rel_leb_correct: + forall x x', + rel_leb x x' = true <-> RELATION.ge x' x. +Proof. + unfold rel_leb, RELATION.ge. + split; auto. +Qed. + +Hint Resolve rel_leb_correct : cse3. + +Lemma relb_leb_correct: + forall x x', + relb_leb x x' = true <-> RB.ge x' x. +Proof. + unfold relb_leb, RB.ge. + destruct x; destruct x'; split; trivial; try contradiction; discriminate. +Qed. + +Hint Resolve relb_leb_correct : cse3. + Theorem loadv_storev_really_same: forall chunk: memory_chunk, forall m1: mem, @@ -708,4 +728,59 @@ Section SOUNDNESS. rewrite forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. assumption. Qed. + + Hint Resolve store_sound : cse3. + + Section INDUCTIVENESS. + Variable fn : RTL.function. + Variable tenv : typing_env. + Variable inv: invariants. + + Definition is_inductive_step (pc pc' : node) := + forall instr, + PTree.get pc (fn_code fn) = Some instr -> + In pc' (successors_instr instr) -> + RB.ge (PMap.get pc' inv) + (apply_instr' (ctx:=ctx) tenv (fn_code fn) pc (PMap.get pc inv)). + + Definition is_inductive_allstep := + forall pc pc', is_inductive_step pc pc'. + + Lemma checked_is_inductive_allstep: + (check_inductiveness (ctx:=ctx) fn tenv inv) = true -> + is_inductive_allstep. + Proof. + unfold check_inductiveness, is_inductive_allstep, is_inductive_step. + rewrite andb_true_iff. + rewrite PTree_Properties.for_all_correct. + intros (ENTRYPOINT & ALL). + intros until instr. + intros INSTR IN_SUCC. + specialize ALL with (x := pc) (a := instr). + pose proof (ALL INSTR) as AT_PC. + destruct (inv # pc). + 2: apply RB.ge_bot. + rewrite List.forallb_forall in AT_PC. + unfold apply_instr'. + rewrite INSTR. + apply relb_leb_correct. + auto. + Qed. + + Lemma checked_is_inductive_entry: + (check_inductiveness (ctx:=ctx) fn tenv inv) = true -> + inv # (fn_entrypoint fn) = Some RELATION.top. + Proof. + unfold check_inductiveness, is_inductive_allstep, is_inductive_step. + rewrite andb_true_iff. + intros (ENTRYPOINT & ALL). + apply RB.beq_correct in ENTRYPOINT. + unfold RB.eq, RELATION.eq in ENTRYPOINT. + destruct (inv # (fn_entrypoint fn)) as [rel | ]. + 2: contradiction. + f_equal. + symmetry. + assumption. + Qed. + End INDUCTIVENESS. End SOUNDNESS. -- cgit From 1746b22de21bb3d07b44b4e2a22e67df6a9842e0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 21:17:02 +0100 Subject: begin writing match states predicates --- backend/CSE3analysisproof.v | 2 ++ backend/CSE3proof.v | 84 ++++++++++++++++++++++++++++++--------------- 2 files changed, 59 insertions(+), 27 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 5514c532..7a74e623 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -783,4 +783,6 @@ Section SOUNDNESS. assumption. Qed. End INDUCTIVENESS. + + Hint Resolve checked_is_inductive_allstep checked_is_inductive_entry : cse3. End SOUNDNESS. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index e277a3e1..0374c934 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -14,7 +14,7 @@ Require Import Globalenvs Values. Require Import Linking Values Memory Globalenvs Events Smallstep. Require Import Registers Op RTL. Require Import CSE3 CSE3analysis CSE3analysisproof. - +Require Import RTLtyping. Section SOUNDNESS. Variable F V : Type. @@ -97,30 +97,56 @@ Proof. eapply function_ptr_translated; eauto. Qed. -Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := -| match_frames_intro: forall res f tf sp pc rs - (FUN : transf_function f = OK tf), - (* (forall m : mem, - forall vres, (fmap_sem' sp m (forward_map f) pc rs # res <- vres)) -> *) - match_frames (Stackframe res f sp pc rs) - (Stackframe res tf sp pc rs). - -Inductive match_states: RTL.state -> RTL.state -> Prop := - | match_regular_states: forall stk tf f sp pc rs m stk' - (STACKS: list_forall2 match_frames stk stk') - (FUN: transf_function f = OK tf), - (* (fmap_sem' sp m (forward_map f) pc rs) -> *) - match_states (State stk f sp pc rs m) - (State stk' tf sp pc rs m) - | match_callstates: forall stk f tf args m stk' - (STACKS: list_forall2 match_frames stk stk') - (FUN: transf_fundef f = OK tf), - match_states (Callstate stk f args m) - (Callstate stk' tf args m) - | match_returnstates: forall stk v m stk' - (STACKS: list_forall2 match_frames stk stk'), - match_states (Returnstate stk v m) - (Returnstate stk' v m). +Inductive match_stackframes: list stackframe -> list stackframe -> signature -> Prop := + | match_stackframes_nil: forall sg, + sg.(sig_res) = Tint -> + match_stackframes nil nil sg + | match_stackframes_cons: + forall res f sp pc rs s tf bb ls ts sg tenv + (STACKS: match_stackframes s ts (fn_sig tf)) + (FUN: transf_function f = OK tf) + (WTF: wt_function f tenv) + (WTRS: wt_regset tenv rs) + (WTRES: tenv res = proj_sig_res sg), + match_stackframes + (Stackframe res f sp pc rs :: s) + (Stackframe res tf sp ls bb :: ts) + sg. + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s f sp pc rs m ts tf tenv + (STACKS: match_stackframes s ts (fn_sig tf)) + (FUN: transf_function f = OK tf) + (WTF: wt_function f tenv) + (WTRS: wt_regset tenv rs), + match_states (State s f sp pc rs m) + (State ts tf sp pc rs m) + | match_states_call: + forall s f args m ts tf + (STACKS: match_stackframes s ts (funsig tf)) + (FUN: transf_fundef f = OK tf) + (WTARGS: Val.has_type_list args (sig_args (funsig tf))), + match_states (Callstate s f args m) + (Callstate ts tf args m) + | match_states_return: + forall s res m ts sg + (STACKS: match_stackframes s ts sg) + (WTRES: Val.has_type res (proj_sig_res sg)), + match_states (Returnstate s res m) + (Returnstate ts res m). + +Lemma match_stackframes_change_sig: + forall s ts sg sg', + match_stackframes s ts sg -> + sg'.(sig_res) = sg.(sig_res) -> + match_stackframes s ts sg'. +Proof. + intros. inv H. + constructor. congruence. + econstructor; eauto. + unfold proj_sig_res in *. rewrite H0; auto. +Qed. Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> @@ -143,11 +169,15 @@ Proof. rewrite symbols_preserved. eauto. symmetry. eapply match_program_main; eauto. + rewrite <- H3. eapply sig_preserved; eauto. - - econstructor; auto. constructor. + - constructor; trivial. + + constructor. rewrite sig_preserved with (f:=f) by assumption. + rewrite H3. reflexivity. + + rewrite sig_preserved with (f:=f) by assumption. + rewrite H3. reflexivity. Qed. Lemma transf_final_states: - forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. + forall S1 S2 r, match_states S1 S2 -> final_state S1 r -> final_state S2 r. Proof. intros. inv H0. inv H. inv STACKS. constructor. Qed. -- cgit From 7bc6519d4f72f2b7f6cd26f177dec12e35a4b47f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 12 Mar 2020 23:38:54 +0100 Subject: proof sketch for CSE3 steps --- backend/CSE3.v | 9 +- backend/CSE3proof.v | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 244 insertions(+), 10 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index f8a25515..161a394a 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -32,7 +32,14 @@ Definition forward_move_b (rb : RB.t) (x : reg) := Definition subst_arg (fmap : PMap.t RB.t) (pc : node) (x : reg) : reg := forward_move_b (PMap.get pc fmap) x. -Definition subst_args fmap pc := List.map (subst_arg fmap pc). +Definition forward_move_l_b (rb : RB.t) (xl : list reg) := + match rb with + | None => xl + | Some rel => forward_move_l (ctx := ctx) rel xl + end. + +Definition subst_args fmap pc xl := + forward_move_l_b (PMap.get pc fmap) xl. Definition transf_instr (fmap : PMap.t RB.t) (pc: node) (instr: instruction) := diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 0374c934..bdf5ecd7 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -85,6 +85,64 @@ Proof. reflexivity. Qed. +Lemma stacksize_preserved: + forall f tf, transf_function f = OK tf -> fn_stacksize tf = fn_stacksize f. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. + inv EQ0. + reflexivity. +Qed. + +Lemma params_preserved: + forall f tf, transf_function f = OK tf -> fn_params tf = fn_params f. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. + inv EQ0. + reflexivity. +Qed. + +Lemma entrypoint_preserved: + forall f tf, transf_function f = OK tf -> fn_entrypoint tf = fn_entrypoint f. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. + inv EQ0. + reflexivity. +Qed. + +Lemma sig_preserved2: + forall f tf, transf_function f = OK tf -> fn_sig tf = fn_sig f. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. + inv EQ0. + reflexivity. +Qed. + +Lemma transf_function_is_typable: + forall f tf, transf_function f = OK tf -> + exists tenv, type_function f = OK tenv. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + exists x. + assumption. +Qed. + Lemma find_function_translated: forall ros rs fd, find_function ge ros rs = Some fd -> @@ -102,15 +160,15 @@ Inductive match_stackframes: list stackframe -> list stackframe -> signature -> sg.(sig_res) = Tint -> match_stackframes nil nil sg | match_stackframes_cons: - forall res f sp pc rs s tf bb ls ts sg tenv + forall res f sp pc rs s tf ts sg tenv (STACKS: match_stackframes s ts (fn_sig tf)) (FUN: transf_function f = OK tf) - (WTF: wt_function f tenv) + (WTF: type_function f = OK tenv) (WTRS: wt_regset tenv rs) (WTRES: tenv res = proj_sig_res sg), match_stackframes (Stackframe res f sp pc rs :: s) - (Stackframe res tf sp ls bb :: ts) + (Stackframe res tf sp pc rs :: ts) sg. Inductive match_states: state -> state -> Prop := @@ -118,7 +176,7 @@ Inductive match_states: state -> state -> Prop := forall s f sp pc rs m ts tf tenv (STACKS: match_stackframes s ts (fn_sig tf)) (FUN: transf_function f = OK tf) - (WTF: wt_function f tenv) + (WTF: type_function f = OK tenv) (WTRS: wt_regset tenv rs), match_states (State s f sp pc rs m) (State ts tf sp pc rs m) @@ -148,11 +206,180 @@ Proof. unfold proj_sig_res in *. rewrite H0; auto. Qed. +Lemma transf_function_at: + forall f tf pc tenv instr + (TF : transf_function f = OK tf) + (TYPE : type_function f = OK tenv) + (PC : (fn_code f) ! pc = Some instr), + (fn_code tf) ! pc = Some (transf_instr + (ctx := (context_from_hints (snd (preanalysis tenv f)))) + (fst (preanalysis tenv f)) + pc instr). +Proof. + intros. + unfold transf_function in TF. + monadInv TF. + replace x with tenv in * by congruence. + clear EQ. + destruct (preanalysis tenv f) as [invariants hints]. + destruct check_inductiveness. + 2: discriminate. + inv EQ0. + simpl. + rewrite PTree.gmap. + rewrite PC. + reflexivity. +Qed. + +Ltac TR_AT := erewrite transf_function_at by eauto. + +Hint Resolve wt_instrs type_function_correct : wt. + +Lemma wt_undef : + forall tenv rs dst, + wt_regset tenv rs -> + wt_regset tenv rs # dst <- Vundef. +Proof. + unfold wt_regset. + intros. + destruct (peq r dst). + { subst dst. + rewrite Regmap.gss. + constructor. + } + rewrite Regmap.gso by congruence. + auto. +Qed. + Lemma step_simulation: - forall S1 t S2, RTL.step ge S1 t S2 -> + forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. Proof. + induction 1; intros S1' MS; inv MS. + - (* Inop *) + exists (State ts tf sp pc' rs m). split. + + apply exec_Inop; auto. + TR_AT. reflexivity. + + econstructor; eauto. + - (* Iop *) + exists (State ts tf sp pc' (rs # res <- v) m). split. + + admit. + + econstructor; eauto. + eapply wt_exec_Iop with (f:=f); try eassumption. + eauto with wt. + - (* Iload *) + exists (State ts tf sp pc' (rs # dst <- v) m). split. + + admit. + + econstructor; eauto. + eapply wt_exec_Iload with (f:=f); try eassumption. + eauto with wt. + - (* Iload notrap1 *) + exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. + + admit. + + econstructor; eauto. + apply wt_undef; assumption. + - (* Iload notrap2 *) + exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. + + admit. + + econstructor; eauto. + apply wt_undef; assumption. + - (* Istore *) + exists (State ts tf sp pc' rs m'). split. + + eapply exec_Istore; try eassumption. + * TR_AT. reflexivity. + * admit. + + econstructor; eauto. + - (* Icall *) + destruct (find_function_translated ros rs fd H0) as [tfd [HTFD1 HTFD2]]. + econstructor. split. + + eapply exec_Icall; try eassumption. + * TR_AT. reflexivity. + * apply sig_preserved; auto. + + admit. + - (* Itailcall *) + destruct (find_function_translated ros rs fd H0) as [tfd [HTFD1 HTFD2]]. + econstructor. split. + + eapply exec_Itailcall; try eassumption. + * TR_AT. reflexivity. + * apply sig_preserved; auto. + * rewrite stacksize_preserved with (f:=f); eauto. + + admit. + - (* Ibuiltin *) + econstructor. split. + + eapply exec_Ibuiltin; try eassumption. + * TR_AT. reflexivity. + * eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + * eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + econstructor; eauto. + eapply wt_exec_Ibuiltin with (f:=f); eauto with wt. + - (* Icond *) + econstructor. split. + + eapply exec_Icond; try eassumption. + * erewrite transf_function_at by eauto. simpl. + admit. + * reflexivity. + + econstructor; eauto. + - (* Ijumptable *) + econstructor. split. + + eapply exec_Ijumptable; try eassumption. + erewrite transf_function_at by eauto. simpl. + admit. + + econstructor; eauto. + - (* Ireturn *) + destruct or. + -- econstructor. split. + + eapply exec_Ireturn; try eassumption. + * erewrite transf_function_at by eauto. simpl. + admit. + * rewrite stacksize_preserved with (f:=f); eauto. + + econstructor; eauto. + simpl. + apply type_function_correct in WTF. + apply wt_instrs with (pc:=pc) (instr:=(Ireturn (Some r))) in WTF. + 2: assumption. + inv WTF. + rewrite sig_preserved2 with (f:=f) by assumption. + rewrite <- H3. + unfold wt_regset in WTRS. + apply WTRS. + -- econstructor. split. + + eapply exec_Ireturn; try eassumption. + * erewrite transf_function_at by eauto. simpl. + admit. + * rewrite stacksize_preserved with (f:=f); eauto. + + econstructor; eauto. + simpl. trivial. + - (* Callstate internal *) + monadInv FUN. + rename x into tf. + destruct (transf_function_is_typable f tf EQ) as [tenv TENV]. + econstructor; split. + + apply exec_function_internal. + rewrite stacksize_preserved with (f:=f); eauto. + + rewrite params_preserved with (tf:=tf) (f:=f) by assumption. + rewrite entrypoint_preserved with (tf:=tf) (f:=f) by assumption. + econstructor; eauto. + apply type_function_correct in TENV. + inv TENV. + simpl in WTARGS. + rewrite sig_preserved2 with (f:=f) in WTARGS by assumption. + apply wt_init_regs. + rewrite <- wt_params in WTARGS. + assumption. + - (* external *) + simpl in FUN. + inv FUN. + econstructor. split. + + eapply exec_function_external. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + econstructor; eauto. + eapply external_call_well_typed; eauto. + - (* return *) + inv STACKS. + econstructor. split. + + eapply exec_return. + + econstructor; eauto. Admitted. Lemma transf_initial_states: @@ -186,10 +413,10 @@ Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). Proof. eapply forward_simulation_step. - apply senv_preserved. - eexact transf_initial_states. - eexact transf_final_states. - exact step_simulation. + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - intros. eapply step_simulation; eauto. Qed. End PRESERVATION. -- cgit From 085e4f45ebf81b7734efa70f018928ac49703f47 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 11:12:00 +0100 Subject: inductive --- backend/CSE3proof.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index bdf5ecd7..f63636ce 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -142,6 +142,19 @@ Proof. exists x. assumption. Qed. +Lemma transf_function_invariants_inductive: + forall f tf tenv, transf_function f = OK tf -> + type_function f = OK tenv -> + check_inductiveness (ctx:=(context_from_hints (snd (preanalysis tenv f)))) + f tenv (fst (preanalysis tenv f)) = true. +Proof. + unfold transf_function; destruct f; simpl; intros. + monadInv H. + replace x with tenv in * by congruence. + clear x. + destruct preanalysis as [invariants hints]. + destruct check_inductiveness; trivial; discriminate. +Qed. Lemma find_function_translated: forall ros rs fd, -- cgit From b27ed35711b59b034dd3900dbca26ac190713cea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 11:44:58 +0100 Subject: fmap_sem --- backend/CSE3analysisproof.v | 6 ++--- backend/CSE3proof.v | 66 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 4 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 7a74e623..155fedef 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -216,9 +216,9 @@ Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). Section SOUNDNESS. - Variable F V : Type. - Variable genv: Genv.t F V. - Variable sp : val. + Context {F V : Type}. + Context {genv: Genv.t F V}. + Context {sp : val}. Context {ctx : eq_context}. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index f63636ce..855f8338 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -16,13 +16,77 @@ Require Import Registers Op RTL. Require Import CSE3 CSE3analysis CSE3analysisproof. Require Import RTLtyping. + Section SOUNDNESS. Variable F V : Type. Variable genv: Genv.t F V. Variable sp : val. + Variable ctx : eq_context. + + Definition sem_rel_b (rel : RB.t) (rs : regset) (m : mem) := + match rel with + | None => False + | Some rel => sem_rel (ctx:=ctx) (genv:=genv) (sp:=sp) rel rs m + end. + + Lemma forward_move_b_sound : + forall rel rs m x, + (sem_rel_b rel rs m) -> + rs # (forward_move_b (ctx := ctx) rel x) = rs # x. + Proof. + destruct rel as [rel | ]; simpl; intros. + 2: contradiction. + eapply forward_move_sound; eauto. + Qed. + + Lemma forward_move_l_b_sound : + forall rel rs m x, + (sem_rel_b rel rs m) -> + rs ## (forward_move_l_b (ctx := ctx) rel x) = rs ## x. + Proof. + destruct rel as [rel | ]; simpl; intros. + 2: contradiction. + eapply forward_move_l_sound; eauto. + Qed. + + Definition fmap_sem (fmap : PMap.t RB.t) (pc : node) (rs : regset) (m : mem) := + sem_rel_b (PMap.get pc fmap) rs m. + + Definition subst_arg (fmap : PMap.t RB.t) (pc : node) (x : reg) : reg := + forward_move_b (ctx:=ctx) (PMap.get pc fmap) x. + + Lemma subst_arg_ok: + forall invariants, + forall pc, + forall rs, + forall m, + forall arg, + forall (SEM : fmap_sem invariants pc rs m), + rs # (subst_arg invariants pc arg) = rs # arg. + Proof. + intros. + apply forward_move_b_sound with (m:=m). + assumption. + Qed. + + Definition subst_args (fmap : PMap.t RB.t) (pc : node) (x : list reg) : list reg := + forward_move_l_b (ctx:=ctx) (PMap.get pc fmap) x. + + Lemma subst_args_ok: + forall invariants, + forall pc, + forall rs, + forall m, + forall args, + forall (SEM : fmap_sem invariants pc rs m), + rs ## (subst_args invariants pc args) = rs ## args. + Proof. + intros. + apply forward_move_l_b_sound with (m:=m). + assumption. + Qed. End SOUNDNESS. - Definition match_prog (p tp: RTL.program) := match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. -- cgit From 84dfe6960d60bb9a41acf33f33042b34f248677b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 12:01:32 +0100 Subject: begin adding invariants and inductiveness --- backend/CSE3proof.v | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 855f8338..0a43a58d 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -242,7 +242,10 @@ Inductive match_stackframes: list stackframe -> list stackframe -> signature -> (FUN: transf_function f = OK tf) (WTF: type_function f = OK tenv) (WTRS: wt_regset tenv rs) - (WTRES: tenv res = proj_sig_res sg), + (WTRES: tenv res = proj_sig_res sg) + (invariants : PMap.t RB.t) + (hints : analysis_hints) + (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants), match_stackframes (Stackframe res f sp pc rs :: s) (Stackframe res tf sp pc rs :: ts) @@ -254,7 +257,10 @@ Inductive match_states: state -> state -> Prop := (STACKS: match_stackframes s ts (fn_sig tf)) (FUN: transf_function f = OK tf) (WTF: type_function f = OK tenv) - (WTRS: wt_regset tenv rs), + (WTRS: wt_regset tenv rs) + (invariants : PMap.t RB.t) + (hints : analysis_hints) + (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants), match_states (State s f sp pc rs m) (State ts tf sp pc rs m) | match_states_call: @@ -437,13 +443,15 @@ Proof. + rewrite params_preserved with (tf:=tf) (f:=f) by assumption. rewrite entrypoint_preserved with (tf:=tf) (f:=f) by assumption. econstructor; eauto. - apply type_function_correct in TENV. - inv TENV. - simpl in WTARGS. - rewrite sig_preserved2 with (f:=f) in WTARGS by assumption. - apply wt_init_regs. - rewrite <- wt_params in WTARGS. - assumption. + * apply type_function_correct in TENV. + inv TENV. + simpl in WTARGS. + rewrite sig_preserved2 with (f:=f) in WTARGS by assumption. + apply wt_init_regs. + rewrite <- wt_params in WTARGS. + assumption. + * apply checked_is_inductive_allstep. + apply transf_function_invariants_inductive with (tf:=tf); auto. - (* external *) simpl in FUN. inv FUN. -- cgit From c8553d8cbad6ea9c0eeba732aa199eefd6d1339f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 15:17:31 +0100 Subject: some progress (but broken proof) --- backend/CSE3proof.v | 123 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 87 insertions(+), 36 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 0a43a58d..8d987e94 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -17,23 +17,37 @@ Require Import CSE3 CSE3analysis CSE3analysisproof. Require Import RTLtyping. +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + Section SOUNDNESS. - Variable F V : Type. - Variable genv: Genv.t F V. - Variable sp : val. - Variable ctx : eq_context. - - Definition sem_rel_b (rel : RB.t) (rs : regset) (m : mem) := - match rel with - | None => False - | Some rel => sem_rel (ctx:=ctx) (genv:=genv) (sp:=sp) rel rs m - end. - - Lemma forward_move_b_sound : - forall rel rs m x, - (sem_rel_b rel rs m) -> - rs # (forward_move_b (ctx := ctx) rel x) = rs # x. - Proof. +Variable sp : val. +Variable ctx : eq_context. + +Definition sem_rel_b (rel : RB.t) (rs : regset) (m : mem) := + match rel with + | None => False + | Some rel => sem_rel (ctx:=ctx) (genv:=ge) (sp:=sp) rel rs m + end. + +Lemma forward_move_b_sound : + forall rel rs m x, + (sem_rel_b rel rs m) -> + rs # (forward_move_b (ctx := ctx) rel x) = rs # x. +Proof. destruct rel as [rel | ]; simpl; intros. 2: contradiction. eapply forward_move_sound; eauto. @@ -87,22 +101,6 @@ Section SOUNDNESS. Qed. End SOUNDNESS. -Definition match_prog (p tp: RTL.program) := - match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variables prog tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - Lemma functions_translated: forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> @@ -232,6 +230,7 @@ Proof. eapply function_ptr_translated; eauto. Qed. +Check sem_rel_b. Inductive match_stackframes: list stackframe -> list stackframe -> signature -> Prop := | match_stackframes_nil: forall sg, sg.(sig_res) = Tint -> @@ -245,7 +244,11 @@ Inductive match_stackframes: list stackframe -> list stackframe -> signature -> (WTRES: tenv res = proj_sig_res sg) (invariants : PMap.t RB.t) (hints : analysis_hints) - (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants), + (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants) + (REL: forall m vres, + sem_rel_b sp (context_from_hints hints) + (invariants#pc) (rs#res <- vres) m), + match_stackframes (Stackframe res f sp pc rs :: s) (Stackframe res tf sp pc rs :: ts) @@ -260,7 +263,8 @@ Inductive match_states: state -> state -> Prop := (WTRS: wt_regset tenv rs) (invariants : PMap.t RB.t) (hints : analysis_hints) - (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants), + (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants) + (REL: sem_rel_b sp (context_from_hints hints) (invariants#pc) rs m), match_states (State s f sp pc rs m) (State ts tf sp pc rs m) | match_states_call: @@ -334,6 +338,21 @@ Proof. auto. Qed. +Lemma rel_ge: + forall inv inv' + (GE : RELATION.ge inv' inv) + ctx sp rs m + (REL: sem_rel (genv:=ge) (sp:=sp) (ctx:=ctx) inv rs m), + sem_rel (genv:=ge) (sp:=sp) (ctx:=ctx) inv' rs m. +Proof. + unfold sem_rel, RELATION.ge. + intros. + apply (REL i); trivial. + eapply HashedSet.PSet.is_subset_spec1; eassumption. +Qed. + +Hint Resolve rel_ge : cse3. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -345,12 +364,44 @@ Proof. + apply exec_Inop; auto. TR_AT. reflexivity. + econstructor; eauto. + + unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND. + specialize IND with (pc:=pc) (pc':=pc') (instr := (Inop pc')). + simpl in IND. + rewrite H in IND. + simpl in IND. + intuition. + unfold sem_rel_b in *. + destruct (invariants # pc') as [inv' | ]; + destruct (invariants # pc) as [inv | ]; + simpl in *; + try contradiction. + eapply rel_ge; eassumption. + - (* Iop *) exists (State ts tf sp pc' (rs # res <- v) m). split. + admit. + econstructor; eauto. - eapply wt_exec_Iop with (f:=f); try eassumption. - eauto with wt. + * eapply wt_exec_Iop with (f:=f); try eassumption. + eauto with wt. + * unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND. + specialize IND with (pc:=pc) (pc':=pc') (instr := (Iop op args res pc')). + simpl in IND. + rewrite H in IND. + simpl in IND. + intuition. + unfold sem_rel_b in *. + destruct (invariants # pc') as [inv' | ]; + destruct (invariants # pc) as [inv | ]; + simpl in *; + try contradiction. + eapply rel_ge. + eassumption. + apply oper_sound; eauto with cse3. + simpl. + rewrite H0. + trivial. + - (* Iload *) exists (State ts tf sp pc' (rs # dst <- v) m). split. + admit. -- cgit From 2e47c928161eebb252fea056495a70d22884efc9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 18:47:13 +0100 Subject: some automation --- backend/CSE3analysisproof.v | 31 +++++++++++++++++++++++ backend/CSE3proof.v | 62 ++++++++++++++++++++++++--------------------- 2 files changed, 64 insertions(+), 29 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 155fedef..cd27a506 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -189,6 +189,22 @@ Proof. eassumption. Qed. +Hint Resolve get_kills_has_lhs : cse3. + +Lemma context_from_hints_get_kills_has_lhs : + forall hints lhs sop args j, + PTree.get j (hint_eq_catalog hints) = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + PSet.contains (eq_kill_reg (context_from_hints hints) lhs) j = true. +Proof. + intros; simpl. + eapply get_kills_has_lhs. + eassumption. +Qed. + +Hint Resolve context_from_hints_get_kills_has_lhs : cse3. + Lemma get_kills_has_arg : forall eqs lhs sop arg args j, PTree.get j eqs = Some {| eq_lhs := lhs; @@ -212,6 +228,21 @@ Qed. Hint Resolve get_kills_has_arg : cse3. +Lemma context_from_hints_get_kills_has_arg : + forall hints lhs sop arg args j, + PTree.get j (hint_eq_catalog hints) = Some {| eq_lhs := lhs; + eq_op := sop; + eq_args:= args |} -> + In arg args -> + PSet.contains (eq_kill_reg (context_from_hints hints) arg) j = true. +Proof. + intros. + simpl. + eapply get_kills_has_arg; eassumption. +Qed. + +Hint Resolve context_from_hints_get_kills_has_arg : cse3. + Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 8d987e94..e18456d2 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -353,6 +353,37 @@ Qed. Hint Resolve rel_ge : cse3. +Lemma sem_rhs_sop : + forall sp op rs args m v, + eval_operation ge sp op rs ## args m = Some v -> + sem_rhs (genv:=ge) (sp:=sp) (SOp op) args rs m v. +Proof. + intros. simpl. + rewrite H. + reflexivity. +Qed. + +Hint Resolve sem_rhs_sop : cse3. + +Ltac IND_STEP := + match goal with + REW: (fn_code ?fn) ! ?mpc = Some ?minstr, + IND: is_inductive_allstep ?fn ?tenv ?invariants + |- + sem_rel_b ?sp ?ctx (?inv # ?mpc') ?rs ?m => + unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND; + specialize IND with (pc:=mpc) (pc':=mpc') (instr:=minstr); + simpl in IND; + rewrite REW in IND; + simpl in IND; + destruct (inv # mpc') as [zinv' | ]; + destruct (inv # mpc) as [zinv | ]; + simpl in *; + intuition; + eapply rel_ge; eauto with cse3; + idtac mpc mpc' fn minstr inv + end. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -364,19 +395,7 @@ Proof. + apply exec_Inop; auto. TR_AT. reflexivity. + econstructor; eauto. - - unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND. - specialize IND with (pc:=pc) (pc':=pc') (instr := (Inop pc')). - simpl in IND. - rewrite H in IND. - simpl in IND. - intuition. - unfold sem_rel_b in *. - destruct (invariants # pc') as [inv' | ]; - destruct (invariants # pc) as [inv | ]; - simpl in *; - try contradiction. - eapply rel_ge; eassumption. + IND_STEP. - (* Iop *) exists (State ts tf sp pc' (rs # res <- v) m). split. @@ -384,23 +403,8 @@ Proof. + econstructor; eauto. * eapply wt_exec_Iop with (f:=f); try eassumption. eauto with wt. - * unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND. - specialize IND with (pc:=pc) (pc':=pc') (instr := (Iop op args res pc')). - simpl in IND. - rewrite H in IND. - simpl in IND. - intuition. - unfold sem_rel_b in *. - destruct (invariants # pc') as [inv' | ]; - destruct (invariants # pc) as [inv | ]; - simpl in *; - try contradiction. - eapply rel_ge. - eassumption. + * IND_STEP. apply oper_sound; eauto with cse3. - simpl. - rewrite H0. - trivial. - (* Iload *) exists (State ts tf sp pc' (rs # dst <- v) m). split. -- cgit From 5e569a91cbdf0357cc2df3fb542291e2ba2a8f70 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 18:59:00 +0100 Subject: progress on inductiveness proof --- backend/CSE3proof.v | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index e18456d2..3cc48cca 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -365,6 +365,19 @@ Qed. Hint Resolve sem_rhs_sop : cse3. +Lemma sem_rhs_sload : + forall sp chunk addr rs args m a v, + eval_addressing ge sp addr rs ## args = Some a -> + Mem.loadv chunk m a = Some v -> + sem_rhs (genv:=ge) (sp:=sp) (SLoad chunk addr) args rs m v. +Proof. + intros. simpl. + rewrite H. rewrite H0. + reflexivity. +Qed. + +Hint Resolve sem_rhs_sload : cse3. + Ltac IND_STEP := match goal with REW: (fn_code ?fn) ! ?mpc = Some ?minstr, @@ -410,8 +423,11 @@ Proof. exists (State ts tf sp pc' (rs # dst <- v) m). split. + admit. + econstructor; eauto. - eapply wt_exec_Iload with (f:=f); try eassumption. - eauto with wt. + * eapply wt_exec_Iload with (f:=f); try eassumption. + eauto with wt. + * IND_STEP. + apply oper_sound; eauto with cse3. + - (* Iload notrap1 *) exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. + admit. -- cgit From 1378e28a9eb2ec73477bc592d586dd6fed8c3928 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 20:20:10 +0100 Subject: moving forward in proofs --- backend/CSE3analysisproof.v | 81 ++++++++++++++++++++++++++++++++++++++++++++- backend/CSE3proof.v | 37 +++++++++++++++++++-- 2 files changed, 115 insertions(+), 3 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index cd27a506..94d3142f 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -120,7 +120,14 @@ Definition xlget_kills (eqs : list (eq_id * equation)) (m : Regmap.t PSet.t) : Regmap.t PSet.t := List.fold_left (fun already (item : eq_id * equation) => add_i_j (eq_lhs (snd item)) (fst item) - (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. + (add_ilist_j (eq_args (snd item)) (fst item) already)) eqs m. + + +Definition xlget_mem_kills (eqs : list (positive * equation)) (m : PSet.t) : PSet.t := +(fold_left + (fun (a : PSet.t) (p : positive * equation) => + if eq_depends_on_mem (snd p) then PSet.add (fst p) a else a) + eqs m). Lemma xlget_kills_monotone : forall eqs m i j, @@ -134,6 +141,24 @@ Qed. Hint Resolve xlget_kills_monotone : cse3. +Lemma xlget_mem_kills_monotone : + forall eqs m j, + PSet.contains m j = true -> + PSet.contains (xlget_mem_kills eqs m) j = true. +Proof. + induction eqs; simpl; trivial. + intros. + destruct eq_depends_on_mem. + - apply IHeqs. + destruct (peq (fst a) j). + + subst j. apply PSet.gadds. + + rewrite PSet.gaddo by congruence. + trivial. + - auto. +Qed. + +Hint Resolve xlget_mem_kills_monotone : cse3. + Lemma xlget_kills_has_lhs : forall eqs m lhs sop args j, In (j, {| eq_lhs := lhs; @@ -243,6 +268,60 @@ Qed. Hint Resolve context_from_hints_get_kills_has_arg : cse3. +Lemma xlget_kills_has_eq_depends_on_mem : + forall eqs eq j m, + In (j, eq) eqs -> + eq_depends_on_mem eq = true -> + PSet.contains (xlget_mem_kills eqs m) j = true. +Proof. + induction eqs; simpl. + contradiction. + intros. + destruct H. + { subst a. + simpl. + rewrite H0. + apply xlget_mem_kills_monotone. + apply PSet.gadds. + } + eauto. +Qed. + +Hint Resolve xlget_kills_has_eq_depends_on_mem : cse3. + +Lemma get_kills_has_eq_depends_on_mem : + forall eqs eq j, + PTree.get j eqs = Some eq -> + eq_depends_on_mem eq = true -> + PSet.contains (get_mem_kills eqs) j = true. +Proof. + intros. + unfold get_mem_kills. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : PSet.t) (p : positive * equation) => + if eq_depends_on_mem (snd p) then PSet.add (fst p) a else a) + (PTree.elements eqs) PSet.empty) + with (xlget_mem_kills (PTree.elements eqs) PSet.empty). + eapply xlget_kills_has_eq_depends_on_mem. + apply PTree.elements_correct. + eassumption. + trivial. +Qed. + +Lemma context_from_hints_get_kills_has_eq_depends_on_mem : + forall hints eq j, + PTree.get j (hint_eq_catalog hints) = Some eq -> + eq_depends_on_mem eq = true -> + PSet.contains (eq_kill_mem (context_from_hints hints) tt) j = true. +Proof. + intros. + simpl. + eapply get_kills_has_eq_depends_on_mem; eassumption. +Qed. + +Hint Resolve context_from_hints_get_kills_has_eq_depends_on_mem : cse3. + Definition eq_involves (eq : equation) (i : reg) := i = (eq_lhs eq) \/ In i (eq_args eq). diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 3cc48cca..6744ee93 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -377,6 +377,31 @@ Proof. Qed. Hint Resolve sem_rhs_sload : cse3. + +Lemma sem_rhs_sload_notrap1 : + forall sp chunk addr rs args m, + eval_addressing ge sp addr rs ## args = None -> + sem_rhs (genv:=ge) (sp:=sp) (SLoad chunk addr) args rs m Vundef. +Proof. + intros. simpl. + rewrite H. + reflexivity. +Qed. + +Hint Resolve sem_rhs_sload_notrap1 : cse3. + +Lemma sem_rhs_sload_notrap2 : + forall sp chunk addr rs args m a, + eval_addressing ge sp addr rs ## args = Some a -> + Mem.loadv chunk m a = None -> + sem_rhs (genv:=ge) (sp:=sp) (SLoad chunk addr) args rs m Vundef. +Proof. + intros. simpl. + rewrite H. rewrite H0. + reflexivity. +Qed. + +Hint Resolve sem_rhs_sload_notrap2 : cse3. Ltac IND_STEP := match goal with @@ -432,18 +457,26 @@ Proof. exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. + admit. + econstructor; eauto. - apply wt_undef; assumption. + * apply wt_undef; assumption. + * IND_STEP. + apply oper_sound; eauto with cse3. + - (* Iload notrap2 *) exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. + admit. + econstructor; eauto. - apply wt_undef; assumption. + * apply wt_undef; assumption. + * IND_STEP. + apply oper_sound; eauto with cse3. + - (* Istore *) exists (State ts tf sp pc' rs m'). split. + eapply exec_Istore; try eassumption. * TR_AT. reflexivity. * admit. + econstructor; eauto. + IND_STEP. + - (* Icall *) destruct (find_function_translated ros rs fd H0) as [tfd [HTFD1 HTFD2]]. econstructor. split. -- cgit From 1e2fc0d53845b530e14a3c5293fbadfaf8285c35 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 20:25:05 +0100 Subject: progress in proofs --- backend/CSE3analysisproof.v | 25 ++++++++----------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 94d3142f..7ddbaed8 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -378,18 +378,9 @@ Section SOUNDNESS. PSet.contains (eq_kill_reg ctx arg) j = true. Hypothesis ctx_kill_mem_has_depends_on_mem : - forall lhs op args j, - eq_catalog ctx j = Some {| eq_lhs := lhs; - eq_op := SOp op; - eq_args:= args |} -> - op_depends_on_memory op = true -> - PSet.contains (eq_kill_mem ctx tt) j = true. - - Hypothesis ctx_kill_mem_has_load : - forall lhs chunk addr args j, - eq_catalog ctx j = Some {| eq_lhs := lhs; - eq_op := SLoad chunk addr; - eq_args:= args |} -> + forall eq j, + eq_catalog ctx j = Some eq -> + eq_depends_on_mem eq = true -> PSet.contains (eq_kill_mem ctx tt) j = true. Theorem kill_reg_sound : @@ -529,17 +520,17 @@ Section SOUNDNESS. rewrite andb_true_iff in SUBTRACT. intuition. destruct (eq_op eq) as [op | chunk addr] eqn:OP. - - specialize ctx_kill_mem_has_depends_on_mem with (lhs := eq_lhs eq) (op := op) (args := eq_args eq) (j := i). + - specialize ctx_kill_mem_has_depends_on_mem with (eq0 := eq) (j := i). + unfold eq_depends_on_mem in ctx_kill_mem_has_depends_on_mem. + rewrite OP in ctx_kill_mem_has_depends_on_mem. rewrite (op_depends_on_memory_correct genv sp op) with (m2 := m). assumption. destruct (op_depends_on_memory op) in *; trivial. rewrite ctx_kill_mem_has_depends_on_mem in H0; trivial. discriminate H0. - rewrite <- OP. - rewrite CATALOG. - destruct eq; reflexivity. - - specialize ctx_kill_mem_has_load with (lhs := eq_lhs eq) (chunk := chunk) (addr := addr) (args := eq_args eq) (j := i). + - specialize ctx_kill_mem_has_depends_on_mem with (eq0 := eq) (j := i). destruct eq as [lhs op args]; simpl in *. + rewrite OP in ctx_kill_mem_has_depends_on_mem. rewrite negb_true_iff in H0. rewrite OP in CATALOG. intuition. -- cgit From 7e4b3b10367e71e74b8eca57d94e4413336411bf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 20:56:49 +0100 Subject: moving forward in proofs --- backend/CSE3proof.v | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 6744ee93..3fbac9ea 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -402,6 +402,17 @@ Proof. Qed. Hint Resolve sem_rhs_sload_notrap2 : cse3. + +Lemma sem_rel_top: + forall ctx sp rs m, sem_rel (genv:=ge) (sp:=sp) (ctx:=ctx) RELATION.top rs m. +Proof. + unfold sem_rel, RELATION.top. + intros. + rewrite HashedSet.PSet.gempty in *. + discriminate. +Qed. + +Hint Resolve sem_rel_top : cse3. Ltac IND_STEP := match goal with @@ -476,6 +487,7 @@ Proof. * admit. + econstructor; eauto. IND_STEP. + apply store_sound with (a0:=a) (m0:=m); eauto with cse3. - (* Icall *) destruct (find_function_translated ros rs fd H0) as [tfd [HTFD1 HTFD2]]. @@ -499,7 +511,8 @@ Proof. * eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. * eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. - eapply wt_exec_Ibuiltin with (f:=f); eauto with wt. + * eapply wt_exec_Ibuiltin with (f:=f); eauto with wt. + * IND_STEP. - (* Icond *) econstructor. split. + eapply exec_Icond; try eassumption. @@ -507,12 +520,17 @@ Proof. admit. * reflexivity. + econstructor; eauto. + destruct b; IND_STEP. + - (* Ijumptable *) econstructor. split. + eapply exec_Ijumptable; try eassumption. erewrite transf_function_at by eauto. simpl. admit. + econstructor; eauto. + assert (In pc' tbl) as IN_LIST by (eapply list_nth_z_in; eassumption). + IND_STEP. + - (* Ireturn *) destruct or. -- econstructor. split. @@ -556,6 +574,7 @@ Proof. assumption. * apply checked_is_inductive_allstep. apply transf_function_invariants_inductive with (tf:=tf); auto. + - (* external *) simpl in FUN. inv FUN. -- cgit From 886c7426af936fc84b0a284a853b659fea386de3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 21:08:21 +0100 Subject: CSE3 proofs: REL is inductive --- backend/CSE3proof.v | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 3fbac9ea..319b7f7e 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -413,6 +413,15 @@ Proof. Qed. Hint Resolve sem_rel_top : cse3. + +Lemma sem_rel_b_top: + forall ctx sp rs m, sem_rel_b sp ctx (Some RELATION.top) rs m. +Proof. + intros. simpl. + apply sem_rel_top. +Qed. + +Hint Resolve sem_rel_b_top : cse3. Ltac IND_STEP := match goal with @@ -574,7 +583,10 @@ Proof. assumption. * apply checked_is_inductive_allstep. apply transf_function_invariants_inductive with (tf:=tf); auto. - + * rewrite @checked_is_inductive_entry with (tenv:=tenv) (ctx:=(context_from_hints (snd (preanalysis tenv f)))). + ** apply sem_rel_b_top. + ** apply transf_function_invariants_inductive with (tf:=tf); auto. + - (* external *) simpl in FUN. inv FUN. -- cgit From 873535d7d6085f5d72ffb4900200eb5565965dfb Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 22:53:20 +0100 Subject: moving forward but could be simplified --- backend/CSE3proof.v | 90 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 64 insertions(+), 26 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 319b7f7e..5812ba1e 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -65,9 +65,6 @@ Proof. Definition fmap_sem (fmap : PMap.t RB.t) (pc : node) (rs : regset) (m : mem) := sem_rel_b (PMap.get pc fmap) rs m. - - Definition subst_arg (fmap : PMap.t RB.t) (pc : node) (x : reg) : reg := - forward_move_b (ctx:=ctx) (PMap.get pc fmap) x. Lemma subst_arg_ok: forall invariants, @@ -76,15 +73,12 @@ Proof. forall m, forall arg, forall (SEM : fmap_sem invariants pc rs m), - rs # (subst_arg invariants pc arg) = rs # arg. + rs # (subst_arg (ctx:=ctx) invariants pc arg) = rs # arg. Proof. intros. apply forward_move_b_sound with (m:=m). assumption. Qed. - - Definition subst_args (fmap : PMap.t RB.t) (pc : node) (x : list reg) : list reg := - forward_move_l_b (ctx:=ctx) (PMap.get pc fmap) x. Lemma subst_args_ok: forall invariants, @@ -93,7 +87,7 @@ Proof. forall m, forall args, forall (SEM : fmap_sem invariants pc rs m), - rs ## (subst_args invariants pc args) = rs ## args. + rs ## (subst_args (ctx:=ctx) invariants pc args) = rs ## args. Proof. intros. apply forward_move_l_b_sound with (m:=m). @@ -242,12 +236,9 @@ Inductive match_stackframes: list stackframe -> list stackframe -> signature -> (WTF: type_function f = OK tenv) (WTRS: wt_regset tenv rs) (WTRES: tenv res = proj_sig_res sg) - (invariants : PMap.t RB.t) - (hints : analysis_hints) - (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants) (REL: forall m vres, - sem_rel_b sp (context_from_hints hints) - (invariants#pc) (rs#res <- vres) m), + sem_rel_b sp (context_from_hints (snd (preanalysis tenv f))) + ((fst (preanalysis tenv f))#pc) (rs#res <- vres) m), match_stackframes (Stackframe res f sp pc rs :: s) @@ -261,10 +252,7 @@ Inductive match_states: state -> state -> Prop := (FUN: transf_function f = OK tf) (WTF: type_function f = OK tenv) (WTRS: wt_regset tenv rs) - (invariants : PMap.t RB.t) - (hints : analysis_hints) - (IND: is_inductive_allstep (ctx:=(context_from_hints hints)) f tenv invariants) - (REL: sem_rel_b sp (context_from_hints hints) (invariants#pc) rs m), + (REL: sem_rel_b sp (context_from_hints (snd (preanalysis tenv f))) ((fst (preanalysis tenv f))#pc) rs m), match_states (State s f sp pc rs m) (State ts tf sp pc rs m) | match_states_call: @@ -422,24 +410,26 @@ Proof. Qed. Hint Resolve sem_rel_b_top : cse3. - + Ltac IND_STEP := match goal with - REW: (fn_code ?fn) ! ?mpc = Some ?minstr, - IND: is_inductive_allstep ?fn ?tenv ?invariants + REW: (fn_code ?fn) ! ?mpc = Some ?minstr |- - sem_rel_b ?sp ?ctx (?inv # ?mpc') ?rs ?m => + sem_rel_b ?sp (context_from_hints (snd (preanalysis ?tenv ?fn))) ((fst (preanalysis ?tenv ?fn)) # ?mpc') ?rs ?m => + assert (is_inductive_allstep (ctx:= (context_from_hints (snd (preanalysis tenv fn)))) fn tenv (fst (preanalysis tenv fn))) as IND by + (apply checked_is_inductive_allstep; + eapply transf_function_invariants_inductive; eassumption); unfold is_inductive_allstep, is_inductive_step, apply_instr' in IND; specialize IND with (pc:=mpc) (pc':=mpc') (instr:=minstr); simpl in IND; rewrite REW in IND; simpl in IND; - destruct (inv # mpc') as [zinv' | ]; - destruct (inv # mpc) as [zinv | ]; + destruct ((fst (preanalysis tenv fn)) # mpc') as [zinv' | ]; + destruct ((fst (preanalysis tenv fn)) # mpc) as [zinv | ]; simpl in *; intuition; eapply rel_ge; eauto with cse3; - idtac mpc mpc' fn minstr inv + idtac mpc mpc' fn minstr end. Lemma step_simulation: @@ -454,10 +444,58 @@ Proof. TR_AT. reflexivity. + econstructor; eauto. IND_STEP. - - (* Iop *) exists (State ts tf sp pc' (rs # res <- v) m). split. - + admit. + + pose (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iop op args res pc')) as instr'. + assert (instr' = (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iop op args res pc'))) by reflexivity. + unfold transf_instr, find_op_in_fmap in instr'. + destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. + pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SOp op) + (CSE3.subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. + * destruct rhs_find eqn:FIND. + ** apply exec_Iop with (op := Omove) (args := r :: nil). + TR_AT. + subst instr'. + congruence. + simpl. + specialize FIND_SOUND with (src := r) (rs := rs) (m := m). + simpl in FIND_SOUND. + rewrite subst_args_ok with (sp:=sp) (m:=m) in FIND_SOUND. + rewrite H0 in FIND_SOUND. + rewrite FIND_SOUND; auto. + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + ** apply exec_Iop with (op := op) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)). + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_operation_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + * apply exec_Iop with (op := op) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)). + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_operation_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + econstructor; eauto. * eapply wt_exec_Iop with (f:=f); try eassumption. eauto with wt. -- cgit From 57345402f1f3c527defb1dc04b406d2a6aca8c72 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 13 Mar 2020 23:03:26 +0100 Subject: moving forward in loads --- backend/CSE3proof.v | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 5812ba1e..9ddd6ba2 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -451,7 +451,7 @@ Proof. unfold transf_instr, find_op_in_fmap in instr'. destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SOp op) - (CSE3.subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. + (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. * destruct rhs_find eqn:FIND. ** apply exec_Iop with (op := Omove) (args := r :: nil). TR_AT. @@ -504,7 +504,57 @@ Proof. - (* Iload *) exists (State ts tf sp pc' (rs # dst <- v) m). split. - + admit. + + pose (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload trap chunk addr args dst pc')) as instr'. + assert (instr' = (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload trap chunk addr args dst pc'))) by reflexivity. + unfold transf_instr, find_load_in_fmap in instr'. + destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. + pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SLoad chunk addr) + (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. + * destruct rhs_find eqn:FIND. + ** apply exec_Iop with (op := Omove) (args := r :: nil). + TR_AT. + subst instr'. + congruence. + simpl. + specialize FIND_SOUND with (src := r) (rs := rs) (m := m). + simpl in FIND_SOUND. + rewrite subst_args_ok with (sp:=sp) (m:=m) in FIND_SOUND. + rewrite H0 in FIND_SOUND. (* ADDR *) + rewrite H1 in FIND_SOUND. (* LOAD *) + rewrite FIND_SOUND; auto. + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + ** apply exec_Iload with (trap := trap) (chunk := chunk) (a := a) (addr := addr) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + * apply exec_Iload with (chunk := chunk) (trap := trap) (addr := addr) (a := a) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + econstructor; eauto. * eapply wt_exec_Iload with (f:=f); try eassumption. eauto with wt. -- cgit From f1a409ffe3a84f1eb6e4027a46d366a7942be0ae Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 06:39:49 +0100 Subject: Icall --- backend/CSE3proof.v | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 9ddd6ba2..54c96cbf 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -592,7 +592,19 @@ Proof. + eapply exec_Icall; try eassumption. * TR_AT. reflexivity. * apply sig_preserved; auto. - + admit. + + rewrite subst_args_ok with (sp:=sp) (m:=m) by trivial. + assert (wt_instr f tenv (Icall (funsig fd) ros args res pc')) as WTcall by eauto with wt. + inv WTcall. + constructor; trivial. + * econstructor; eauto. + ** rewrite sig_preserved with (f:=fd); assumption. + ** intros. + IND_STEP. + apply kill_reg_sound; eauto with cse3. + eapply kill_mem_sound; eauto with cse3. + * rewrite sig_preserved with (f:=fd) by trivial. + rewrite <- H7. + apply wt_regset_list; auto. - (* Itailcall *) destruct (find_function_translated ros rs fd H0) as [tfd [HTFD1 HTFD2]]. econstructor. split. -- cgit From 0203dc3fea6b05b3929ac6bd458ff432285b8c00 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 06:59:27 +0100 Subject: Itailcall --- backend/CSE3proof.v | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 54c96cbf..3a7590ea 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -612,7 +612,25 @@ Proof. * TR_AT. reflexivity. * apply sig_preserved; auto. * rewrite stacksize_preserved with (f:=f); eauto. - + admit. + + rewrite subst_args_ok with (m:=m) (sp := (Vptr stk Ptrofs.zero)) by trivial. + assert (wt_instr f tenv (Itailcall (funsig fd) ros args)) as WTcall by eauto with wt. + inv WTcall. + constructor; trivial. + * rewrite sig_preserved with (f:=fd) by trivial. + inv STACKS. + ** econstructor; eauto. + rewrite H7. + rewrite <- sig_preserved2 with (tf:=tf) by trivial. + assumption. + ** econstructor; eauto. + unfold proj_sig_res in *. + rewrite H7. + rewrite WTRES. + rewrite sig_preserved2 with (f:=f) by trivial. + reflexivity. + * rewrite sig_preserved with (f:=fd) by trivial. + rewrite <- H6. + apply wt_regset_list; auto. - (* Ibuiltin *) econstructor. split. + eapply exec_Ibuiltin; try eassumption. @@ -681,8 +699,6 @@ Proof. apply wt_init_regs. rewrite <- wt_params in WTARGS. assumption. - * apply checked_is_inductive_allstep. - apply transf_function_invariants_inductive with (tf:=tf); auto. * rewrite @checked_is_inductive_entry with (tenv:=tenv) (ctx:=(context_from_hints (snd (preanalysis tenv f)))). ** apply sem_rel_b_top. ** apply transf_function_invariants_inductive with (tf:=tf); auto. -- cgit From 8b9a4cb340bc135da9907c7d313caa11d078cb16 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 07:56:47 +0100 Subject: Icond --- backend/CSE3proof.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 3a7590ea..8a49fe87 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -642,9 +642,10 @@ Proof. * IND_STEP. - (* Icond *) econstructor. split. - + eapply exec_Icond; try eassumption. - * erewrite transf_function_at by eauto. simpl. - admit. + + eapply exec_Icond with (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); try eassumption. + * TR_AT. reflexivity. + * rewrite subst_args_ok with (sp:=sp) (m:=m) by trivial. + eassumption. * reflexivity. + econstructor; eauto. destruct b; IND_STEP. -- cgit From 71a3e11b500713b53f13fe64b87ebeb1c9c6e312 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:00:06 +0100 Subject: Ijumptable --- backend/CSE3proof.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 8a49fe87..cd129cb2 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -652,9 +652,10 @@ Proof. - (* Ijumptable *) econstructor. split. - + eapply exec_Ijumptable; try eassumption. - erewrite transf_function_at by eauto. simpl. - admit. + + eapply exec_Ijumptable with (arg := (subst_arg (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc arg)); try eassumption. + * TR_AT. reflexivity. + * rewrite subst_arg_ok with (sp:=sp) (m:=m) by trivial. + assumption. + econstructor; eauto. assert (In pc' tbl) as IN_LIST by (eapply list_nth_z_in; eassumption). IND_STEP. -- cgit From 74fef42251167061e7fd863ac2bb06bb6e58d3d4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:04:52 +0100 Subject: Ireturn --- backend/CSE3proof.v | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index cd129cb2..2a33fa1c 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -661,16 +661,16 @@ Proof. IND_STEP. - (* Ireturn *) - destruct or. + destruct or as [arg | ]. -- econstructor. split. - + eapply exec_Ireturn; try eassumption. - * erewrite transf_function_at by eauto. simpl. - admit. + + eapply exec_Ireturn with (or := Some (subst_arg (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc arg)). + * TR_AT. reflexivity. * rewrite stacksize_preserved with (f:=f); eauto. - + econstructor; eauto. - simpl. + + simpl. + rewrite subst_arg_ok with (sp:=(Vptr stk Ptrofs.zero)) (m:=m) by trivial. + econstructor; eauto. apply type_function_correct in WTF. - apply wt_instrs with (pc:=pc) (instr:=(Ireturn (Some r))) in WTF. + apply wt_instrs with (pc:=pc) (instr:=(Ireturn (Some arg))) in WTF. 2: assumption. inv WTF. rewrite sig_preserved2 with (f:=f) by assumption. -- cgit From c875003382b2741557d6657ab4611a4c4fa8e9c6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:05:37 +0100 Subject: Ireturn --- backend/CSE3proof.v | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 2a33fa1c..a6fc73aa 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -679,8 +679,7 @@ Proof. apply WTRS. -- econstructor. split. + eapply exec_Ireturn; try eassumption. - * erewrite transf_function_at by eauto. simpl. - admit. + * TR_AT; reflexivity. * rewrite stacksize_preserved with (f:=f); eauto. + econstructor; eauto. simpl. trivial. -- cgit From 54544caeeb95437741a543a50ed22b8e5549691f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:10:03 +0100 Subject: Iload notrap --- backend/CSE3proof.v | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 101 insertions(+), 2 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index a6fc73aa..888aa55e 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -563,7 +563,56 @@ Proof. - (* Iload notrap1 *) exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. - + admit. + + pose (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload NOTRAP chunk addr args dst pc')) as instr'. + assert (instr' = (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload NOTRAP chunk addr args dst pc'))) by reflexivity. + unfold transf_instr, find_load_in_fmap in instr'. + destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. + pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SLoad chunk addr) + (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. + * destruct rhs_find eqn:FIND. + ** apply exec_Iop with (op := Omove) (args := r :: nil). + TR_AT. + subst instr'. + congruence. + simpl. + specialize FIND_SOUND with (src := r) (rs := rs) (m := m). + simpl in FIND_SOUND. + rewrite subst_args_ok with (sp:=sp) (m:=m) in FIND_SOUND. + rewrite H0 in FIND_SOUND. (* ADDR *) + rewrite FIND_SOUND; auto. + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + ** apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + * apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + econstructor; eauto. * apply wt_undef; assumption. * IND_STEP. @@ -571,7 +620,57 @@ Proof. - (* Iload notrap2 *) exists (State ts tf sp pc' (rs # dst <- Vundef) m). split. - + admit. + + pose (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload NOTRAP chunk addr args dst pc')) as instr'. + assert (instr' = (transf_instr (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc (Iload NOTRAP chunk addr args dst pc'))) by reflexivity. + unfold transf_instr, find_load_in_fmap in instr'. + destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. + pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SLoad chunk addr) + (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. + * destruct rhs_find eqn:FIND. + ** apply exec_Iop with (op := Omove) (args := r :: nil). + TR_AT. + subst instr'. + congruence. + simpl. + specialize FIND_SOUND with (src := r) (rs := rs) (m := m). + simpl in FIND_SOUND. + rewrite subst_args_ok with (sp:=sp) (m:=m) in FIND_SOUND. + rewrite H0 in FIND_SOUND. (* ADDR *) + rewrite H1 in FIND_SOUND. (* LOAD *) + rewrite FIND_SOUND; auto. + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + ** apply exec_Iload_notrap2 with (chunk := chunk) (a := a) (addr := addr) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + * apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (a := a) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); trivial. + TR_AT. + { subst instr'. + congruence. } + rewrite subst_args_ok with (sp:=sp) (m:=m). + { + rewrite eval_addressing_preserved with (ge1:=ge) by exact symbols_preserved. + assumption. + } + unfold fmap_sem. + change ((fst (preanalysis tenv f)) # pc) + with (@PMap.get (option RELATION.t) pc (@fst invariants analysis_hints (preanalysis tenv f))). + rewrite INV_PC. + assumption. + econstructor; eauto. * apply wt_undef; assumption. * IND_STEP. -- cgit From b2c91fd80fc88f4583ceee56243c5845cb1a93ef Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:15:48 +0100 Subject: no more 'admit' in CSE3 --- backend/CSE3proof.v | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 888aa55e..a6de5a5f 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -678,9 +678,11 @@ Proof. - (* Istore *) exists (State ts tf sp pc' rs m'). split. - + eapply exec_Istore; try eassumption. + + eapply exec_Istore with (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); try eassumption. * TR_AT. reflexivity. - * admit. + * rewrite subst_args_ok with (sp:=sp) (m:=m) by trivial. + rewrite eval_addressing_preserved with (ge1 := ge) by exact symbols_preserved. + assumption. + econstructor; eauto. IND_STEP. apply store_sound with (a0:=a) (m0:=m); eauto with cse3. -- cgit From d5e49c9d1e68a2b5305fb18b051a272345283275 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 08:25:57 +0100 Subject: is_trivial_op in CSE3 --- backend/CSE3proof.v | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index a6de5a5f..1472fbb1 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -432,6 +432,12 @@ Ltac IND_STEP := idtac mpc mpc' fn minstr end. +Lemma if_same : forall {T : Type} (b : bool) (x : T), + (if b then x else x) = x. +Proof. + destruct b; trivial. +Qed. + Lemma step_simulation: forall S1 t S2, RTL.step ge S1 t S2 -> forall S1', match_states S1 S1' -> @@ -452,8 +458,13 @@ Proof. destruct (@PMap.get (option RELATION.t) pc) eqn:INV_PC. pose proof (rhs_find_sound (sp:=sp) (genv:=ge) (ctx:=(context_from_hints (snd (preanalysis tenv f)))) pc (SOp op) (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args) t) as FIND_SOUND. - * destruct rhs_find eqn:FIND. - ** apply exec_Iop with (op := Omove) (args := r :: nil). + * destruct (if is_trivial_op op + then None + else + rhs_find pc (SOp op) + (subst_args (fst (preanalysis tenv f)) pc args) t) eqn:FIND. + ** destruct (is_trivial_op op). discriminate. + apply exec_Iop with (op := Omove) (args := r :: nil). TR_AT. subst instr'. congruence. @@ -483,8 +494,9 @@ Proof. rewrite INV_PC. assumption. * apply exec_Iop with (op := op) (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)). - TR_AT. - { subst instr'. + TR_AT. + { subst instr'. + rewrite if_same in H1. congruence. } rewrite subst_args_ok with (sp:=sp) (m:=m). { -- cgit From bbe0809b3cd483ce5fc82e4f2d0a106823c54f26 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 09:19:26 +0100 Subject: CSE3 alias analysis --- backend/CSE3.v | 2 +- backend/CSE3analysis.v | 25 +++++++++++++++++++++++-- backend/CSE3analysisproof.v | 39 ++++++++++++++++++++++++++++++++++++++- driver/Clflags.ml | 5 +++-- driver/Compopts.v | 3 +++ driver/Driver.ml | 6 ++++-- extraction/extraction.v | 2 ++ 7 files changed, 74 insertions(+), 8 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index 161a394a..d0dc3aef 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -46,7 +46,7 @@ Definition transf_instr (fmap : PMap.t RB.t) match instr with | Iop op args dst s => let args' := subst_args fmap pc args in - match find_op_in_fmap fmap pc op args' with + match (if is_trivial_op op then None else find_op_in_fmap fmap pc op args') with | None => Iop op args' dst s | Some src => Iop Omove (src::nil) dst s end diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 76723f40..12fb2d1f 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -2,7 +2,7 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps CSE2deps. Require Import HashedSet. -Require List. +Require List Compopts. Definition typing_env := reg -> typ. @@ -278,10 +278,31 @@ Section OPERATIONS. | None => oper1 dst op args rel end. + Definition clever_kill_store + (chunk : memory_chunk) (addr: addressing) (args : list reg) + (src : reg) + (rel : RELATION.t) : RELATION.t := + PSet.subtract rel + (PSet.filter + (fun eqno => + match eq_catalog ctx eqno with + | None => false + | Some eq => + match eq_op eq with + | SOp op => true + | SLoad chunk' addr' => + may_overlap chunk addr args chunk' addr' (eq_args eq) + end + end) + (PSet.inter rel (eq_kill_mem ctx tt))). + Definition store2 (chunk : memory_chunk) (addr: addressing) (args : list reg) (src : reg) - (rel : RELATION.t) : RELATION.t := kill_mem rel. + (rel : RELATION.t) : RELATION.t := + if Compopts.optim_CSE3_alias_analysis tt + then clever_kill_store chunk addr args src rel + else kill_mem rel. Definition store1 (chunk : memory_chunk) (addr: addressing) (args : list reg) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 7ddbaed8..b87ec92c 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -765,6 +765,43 @@ Section SOUNDNESS. Hint Resolve oper_sound : cse3. + + Theorem clever_kill_store_sound: + forall chunk addr args a src rel rs m m', + sem_rel rel rs m -> + eval_addressing genv sp addr (rs ## args) = Some a -> + Mem.storev chunk m a (rs # src) = Some m' -> + sem_rel (clever_kill_store (ctx:=ctx) chunk addr args src rel) rs m'. + Proof. + unfold clever_kill_store. + intros until m'. intros REL ADDR STORE i eq CONTAINS CATALOG. + autorewrite with pset in CONTAINS. + destruct (PSet.contains rel i) eqn:RELi; simpl in CONTAINS. + 2: discriminate. + rewrite CATALOG in CONTAINS. + unfold sem_rel in REL. + specialize REL with (i := i) (eq0 := eq). + destruct eq; simpl in *. + unfold sem_eq in *. + simpl in *. + destruct eq_op as [op' | chunk' addr']; simpl. + - destruct (op_depends_on_memory op') eqn:DEPENDS. + + erewrite ctx_kill_mem_has_depends_on_mem in CONTAINS by eauto. + discriminate. + + rewrite op_depends_on_memory_correct with (m2:=m); trivial. + apply REL; auto. + - simpl in REL. + erewrite ctx_kill_mem_has_depends_on_mem in CONTAINS by eauto. + simpl in CONTAINS. + rewrite negb_true_iff in CONTAINS. + destruct (eval_addressing genv sp addr' rs ## eq_args) as [a'|] eqn:ADDR'. + + erewrite may_overlap_sound with (chunk:=chunk) (addr:=addr) (args:=args) (chunk':=chunk') (addr':=addr') (args':=eq_args); try eassumption. + apply REL; auto. + + apply REL; auto. + Qed. + + Hint Resolve clever_kill_store_sound : cse3. + Theorem store2_sound: forall chunk addr args a src rel rs m m', sem_rel rel rs m -> @@ -774,7 +811,7 @@ Section SOUNDNESS. Proof. unfold store2. intros. - apply kill_mem_sound with (m:=m); auto. + destruct (Compopts.optim_CSE3_alias_analysis tt); eauto with cse3. Qed. Hint Resolve store2_sound : cse3. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 7e3b23d8..a8594be4 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -25,9 +25,10 @@ let option_ffpu = ref true let option_ffloatconstprop = ref 2 let option_ftailcalls = ref true let option_fconstprop = ref true -let option_fcse = ref true -let option_fcse2 = ref true +let option_fcse = ref false +let option_fcse2 = ref false let option_fcse3 = ref true +let option_fcse3_alias_analysis = ref true let option_fredundancy = ref true let option_fduplicate = ref 0 let option_finvertcond = ref true diff --git a/driver/Compopts.v b/driver/Compopts.v index 1f952164..f1ab4f7b 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -46,6 +46,9 @@ Parameter optim_CSE2: unit -> bool. (** Flag -fcse3. For DMonniaux's common subexpression elimination. *) Parameter optim_CSE3: unit -> bool. +(** Flag -fcse3-alias-analysis. For DMonniaux's common subexpression elimination. *) +Parameter optim_CSE3_alias_analysis: unit -> bool. + (** Flag -fredundancy. For dead code elimination. *) Parameter optim_redundancy: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index 12b61d86..133bac0a 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -194,9 +194,10 @@ Processing options: -fconst-prop Perform global constant propagation [on] -ffloat-const-prop Control constant propagation of floats (=0: none, =1: limited, =2: full; default is full) - -fcse Perform common subexpression elimination [on] - -fcse2 Perform inter-loop common subexpression elimination [on] + -fcse Perform common subexpression elimination [off] + -fcse2 Perform inter-loop common subexpression elimination [off] -fcse3 Perform inter-loop common subexpression elimination [on] + -fcse3-alias-analysis Perform inter-loop common subexpression elimination with alias analysis [on] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] @@ -393,6 +394,7 @@ let cmdline_actions = @ f_opt "cse" option_fcse @ f_opt "cse2" option_fcse2 @ f_opt "cse3" option_fcse3 + @ f_opt "cse3-alias-analysis" option_fcse3_alias_analysis @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass @ [ Exact "-fduplicate", Integer (fun n -> option_fduplicate := n) ] diff --git a/extraction/extraction.v b/extraction/extraction.v index 9b47b203..f868264c 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -116,6 +116,8 @@ Extract Constant Compopts.optim_CSE2 => "fun _ -> !Clflags.option_fcse2". Extract Constant Compopts.optim_CSE3 => "fun _ -> !Clflags.option_fcse3". +Extract Constant Compopts.optim_CSE3_alias_analysis => + "fun _ -> !Clflags.option_fcse3_alias_analysis". Extract Constant Compopts.optim_redundancy => "fun _ -> !Clflags.option_fredundancy". Extract Constant Compopts.optim_postpass => -- cgit From 5e045a7b8c6b834dfec782ecdadae3145a16212e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 14 Mar 2020 09:22:28 +0100 Subject: test for CSE3 alias analysis --- test/monniaux/cse2/storeload.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/monniaux/cse2/storeload.c b/test/monniaux/cse2/storeload.c index 3fa5b226..028fb835 100644 --- a/test/monniaux/cse2/storeload.c +++ b/test/monniaux/cse2/storeload.c @@ -1,4 +1,5 @@ int toto(int *p, int x) { - *p = x; + p[0] = x; + p[1] = 3; return *p; } -- cgit From b1c8e25e7756be73d16cc6dd08879f1f552ce5fc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 27 Mar 2020 15:16:21 +0100 Subject: pass to insert a nop at start position in functions --- Makefile | 1 + backend/FirstNop.v | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) create mode 100644 backend/FirstNop.v diff --git a/Makefile b/Makefile index 623cbad4..8aa5e98a 100644 --- a/Makefile +++ b/Makefile @@ -94,6 +94,7 @@ BACKEND=\ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ ForwardMoves.v ForwardMovesproof.v \ + FirstNop.v \ Allnontrap.v Allnontrapproof.v \ Allocation.v Allocproof.v \ Tunneling.v Tunnelingproof.v \ diff --git a/backend/FirstNop.v b/backend/FirstNop.v new file mode 100644 index 00000000..3d2211bc --- /dev/null +++ b/backend/FirstNop.v @@ -0,0 +1,18 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. + +Definition transf_function (f: function) : function := + let start_pc := max_pc_function f in + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.set start_pc (Inop f.(fn_entrypoint)) f.(fn_code); + fn_entrypoint := start_pc |}. + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. + -- cgit From 3136a5071d92ba5dfa304d8a7177cda266f501e1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 28 Mar 2020 23:24:16 +0100 Subject: pass to insert a "nop" at head of each function --- backend/FirstNop.v | 2 +- backend/FirstNopproof.v | 274 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 275 insertions(+), 1 deletion(-) create mode 100644 backend/FirstNopproof.v diff --git a/backend/FirstNop.v b/backend/FirstNop.v index 3d2211bc..f7e5261e 100644 --- a/backend/FirstNop.v +++ b/backend/FirstNop.v @@ -3,7 +3,7 @@ Require Import AST Linking. Require Import Memory Registers Op RTL. Definition transf_function (f: function) : function := - let start_pc := max_pc_function f in + let start_pc := Pos.succ (max_pc_function f) in {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); fn_stacksize := f.(fn_stacksize); diff --git a/backend/FirstNopproof.v b/backend/FirstNopproof.v new file mode 100644 index 00000000..5d9a7d6a --- /dev/null +++ b/backend/FirstNopproof.v @@ -0,0 +1,274 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import FirstNop. +Require Import Lia. + +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (Genv.find_funct_transf TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. +Proof. + destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + unfold find_function; intros. destruct ros as [r|id]. + eapply functions_translated; eauto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. +Qed. + +Lemma transf_function_at: + forall f pc i, + f.(fn_code)!pc = Some i -> + (transf_function f).(fn_code)!pc = Some i. +Proof. + intros until i. intro Hcode. + unfold transf_function; simpl. + destruct (peq pc (Pos.succ (max_pc_function f))) as [EQ | NEQ]. + { assert (pc <= (max_pc_function f))%positive as LE by (eapply max_pc_function_sound; eassumption). + subst pc. + lia. + } + rewrite PTree.gso by congruence. + assumption. +Qed. + +Hint Resolve transf_function_at : firstnop. + +Ltac TR_AT := + match goal with + | [ A: (fn_code _)!_ = Some _ |- _ ] => + generalize (transf_function_at _ _ _ A); intros + end. + + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := +| match_frames_intro: forall res f sp pc rs, + match_frames (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). + +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (State stk f sp pc rs m) + (State stk' (transf_function f) sp pc rs m) + | match_callstates: forall stk f args m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Callstate stk f args m) + (Callstate stk' (transf_fundef f) args m) + | match_returnstates: forall stk v m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Returnstate stk v m) + (Returnstate stk' v m). + +(* +Lemma match_pc_refl : forall f pc, match_pc f pc pc. +Proof. + unfold match_pc. + left. + trivial. +Qed. + +Hint Resolve match_pc_refl : firstnop. + +Lemma initial_jump: + forall f, + (fn_code (transf_function f)) ! (Pos.succ (max_pc_function f)) = + Some (Inop (fn_entrypoint f)). +Proof. + intros. unfold transf_function. simpl. + apply PTree.gss. +Qed. + +Hint Resolve initial_jump : firstnop. + *) + +Lemma match_pc_same : + forall f pc i, + PTree.get pc (fn_code f) = Some i -> + PTree.get pc (fn_code (transf_function f)) = Some i. +Proof. + intros. + unfold transf_function. simpl. + rewrite <- H. + apply PTree.gso. + pose proof (max_pc_function_sound f pc i H) as LE. + unfold Ple in LE. + lia. +Qed. + +Hint Resolve match_pc_same : firstnop. + + +Definition measure (S: RTL.state) : nat := + match S with + | State _ _ _ _ _ _ => 0%nat + | Callstate _ _ _ _ => 1%nat + | Returnstate _ _ _ => 0%nat + end. + +Lemma step_simulation: + forall S1 t S2, + step ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros; inv MS. + - left. econstructor. split. + + eapply plus_one. eapply exec_Inop; eauto with firstnop. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iop with (v:=v); eauto with firstnop. + rewrite <- H0. + apply eval_operation_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload with (v:=v); eauto with firstnop. + rewrite <- H0. + apply eval_addressing_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload_notrap1; eauto with firstnop. + rewrite <- H0. + apply eval_addressing_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload_notrap2; eauto with firstnop. + rewrite <- H0. + apply eval_addressing_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Istore; eauto with firstnop. + rewrite <- H0. + apply eval_addressing_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Icall. + apply match_pc_same. exact H. + apply find_function_translated. + exact H0. + apply sig_preserved. + + constructor. + constructor; auto. + constructor. + - left. econstructor. split. + + eapply plus_one. eapply exec_Itailcall. + apply match_pc_same. exact H. + apply find_function_translated. + exact H0. + apply sig_preserved. + unfold transf_function; simpl. + eassumption. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ibuiltin; eauto with firstnop. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Icond; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ijumptable; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ireturn; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_two. + * eapply exec_function_internal; eauto with firstnop. + * eapply exec_Inop. + unfold transf_function; simpl. + rewrite PTree.gss. + reflexivity. + * auto. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_function_external; eauto with firstnop. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor; auto. + - left. + inv STACKS. inv H1. + econstructor; split. + + eapply plus_one. eapply exec_return; eauto. + + constructor; auto. +Qed. + +Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. +Proof. + intros. inv H. econstructor; split. + econstructor. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. + eapply function_ptr_translated; eauto. + rewrite <- H3; apply sig_preserved. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. +Proof. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + eapply forward_simulation_star. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 07f2bfbd62568e2e0d983ccb33d020bf6985e874 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 29 Mar 2020 18:30:01 +0200 Subject: nop insertion at entrypoint --- Makefile | 2 +- driver/Compiler.v | 38 +++++++++++++++++++++++--------------- 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/Makefile b/Makefile index 8aa5e98a..ec5e2cd0 100644 --- a/Makefile +++ b/Makefile @@ -94,7 +94,7 @@ BACKEND=\ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ ForwardMoves.v ForwardMovesproof.v \ - FirstNop.v \ + FirstNop.v FirstNopproof.v \ Allnontrap.v Allnontrapproof.v \ Allocation.v Allocproof.v \ Tunneling.v Tunnelingproof.v \ diff --git a/driver/Compiler.v b/driver/Compiler.v index 47fb8236..cc1e7917 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -37,6 +37,7 @@ Require Selection. Require RTLgen. Require Tailcall. Require Inlining. +Require FirstNop. Require Renumber. Require Duplicate. Require Constprop. @@ -63,6 +64,7 @@ Require Selectionproof. Require RTLgenproof. Require Tailcallproof. Require Inliningproof. +Require FirstNopproof. Require Renumberproof. Require Duplicateproof. Require Constpropproof. @@ -134,28 +136,30 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 1) @@@ time "Inlining" Inlining.transf_program @@ print (print_RTL 2) - @@ time "Renumbering" Renumber.transf_program + @@ time "Inserting initial nop" FirstNop.transf_program @@ print (print_RTL 3) - @@@ time "Tail-duplicating" Duplicate.transf_program + @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 4) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) + @@@ time "Tail-duplicating" Duplicate.transf_program @@ print (print_RTL 5) - @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) + @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 6) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) + @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) @@ print (print_RTL 7) - @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) + @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 8) - @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) + @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 9) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program + @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) @@ print (print_RTL 10) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 11) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 12) - @@@ time "Unused globals" Unusedglob.transform_program + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program @@ print (print_RTL 13) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 14) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -257,6 +261,7 @@ Definition CompCert's_passes := ::: mkpass RTLgenproof.match_prog ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog + ::: mkpass FirstNopproof.match_prog ::: mkpass Renumberproof.match_prog ::: mkpass Duplicateproof.match_prog ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) @@ -305,8 +310,9 @@ Proof. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. - set (p9 := Renumber.transf_program p8) in *. - destruct (Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate. + set (p9 := FirstNop.transf_program p8) in *. + set (p9bis := Renumber.transf_program p9) in *. + destruct (Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. @@ -331,7 +337,8 @@ Proof. exists p6; split. apply RTLgenproof.transf_program_match; auto. exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. exists p8; split. apply Inliningproof.transf_program_match; auto. - exists p9; split. apply Renumberproof.transf_program_match; auto. + exists p9; split. apply FirstNopproof.transf_program_match; auto. + exists p9bis; split. apply Renumberproof.transf_program_match; auto. exists p10; split. apply Duplicateproof.transf_program_match; auto. exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match. exists p12; split. apply total_if_match. apply Renumberproof.transf_program_match. @@ -399,7 +406,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p26)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p27)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -417,6 +424,7 @@ Ltac DestructM := eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. eapply compose_forward_simulations. eapply Inliningproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. eapply FirstNopproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Duplicateproof.transf_program_correct; eassumption. -- cgit From 4aad20a92dc926d8c537e65946ca03bf2b6b02b9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 29 Mar 2020 23:01:15 +0200 Subject: begin coding dead code injector --- backend/Inject.v | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 backend/Inject.v diff --git a/backend/Inject.v b/backend/Inject.v new file mode 100644 index 00000000..dd70556a --- /dev/null +++ b/backend/Inject.v @@ -0,0 +1,60 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. + +Inductive inj_instr : Type := + | INJop: operation -> list reg -> reg -> inj_instr + | INJload: memory_chunk -> addressing -> list reg -> reg -> inj_instr. + +Definition inject_instr (i : inj_instr) (pc' : node) : instruction := + match i with + | INJop op args dst => Iop op args dst pc' + | INJload chunk addr args dst => Iload NOTRAP chunk addr args dst pc' + end. + +Fixpoint inject_list (prog : code) (pc : node) (dst : node) + (l : list inj_instr) : node * code := + let pc' := Pos.succ pc in + match l with + | nil => (pc', PTree.set pc (Inop dst) prog) + | h::t => + inject_list (PTree.set pc (inject_instr h pc') prog) + pc' dst t + end. + +Definition successor (i : instruction) : node := + match i with + | Inop pc' => pc' + | Iop _ _ _ pc' => pc' + | Iload _ _ _ _ _ pc' => pc' + | Istore _ _ _ _ pc' => pc' + | Icall _ _ _ _ pc' => pc' + | Ibuiltin _ _ _ pc' => pc' + | Icond _ _ pc' _ => pc' + | Itailcall _ _ _ + | Ijumptable _ _ + | Ireturn _ => 1%positive + end. + +Definition alter_successor (i : instruction) (pc' : node) : instruction := + match i with + | Inop _ => Inop pc' + | Iop op args dst _ => Iop op args dst pc' + | Iload trap chunk addr args dst _ => Iload trap chunk addr args dst pc' + | Istore chunk addr args src _ => Istore chunk addr args src pc' + | Icall sig ri args dst _ => Icall sig ri args dst pc' + | Ibuiltin ef args res _ => Ibuiltin ef args res pc' + | Icond cond args _ pc2 => Icond cond args pc' pc2 + | Itailcall _ _ _ + | Ijumptable _ _ + | Ireturn _ => i + end. + +Definition inject_at (prog : code) (pc extra_pc : node) + (l : list inj_instr) : node * code := + match PTree.get pc prog with + | Some i => + inject_list (PTree.set pc (alter_successor i extra_pc) prog) + extra_pc (successor i) l + | None => inject_list prog extra_pc 1%positive l (* does not happen *) + end. -- cgit From fd00d28f8065acf9b09a6510e1612a91e30ca29c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 10:12:09 +0200 Subject: more on injection --- Makefile | 1 + backend/Inject.v | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index ec5e2cd0..4cf9ccf1 100644 --- a/Makefile +++ b/Makefile @@ -86,6 +86,7 @@ BACKEND=\ Kildall.v Liveness.v \ ValueDomain.v ValueAOp.v ValueAnalysis.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ + Inject.v \ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ diff --git a/backend/Inject.v b/backend/Inject.v index dd70556a..66ef9ce8 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -2,6 +2,8 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. +Local Open Scope positive. + Inductive inj_instr : Type := | INJop: operation -> list reg -> reg -> inj_instr | INJload: memory_chunk -> addressing -> list reg -> reg -> inj_instr. @@ -33,7 +35,7 @@ Definition successor (i : instruction) : node := | Icond _ _ pc' _ => pc' | Itailcall _ _ _ | Ijumptable _ _ - | Ireturn _ => 1%positive + | Ireturn _ => 1 end. Definition alter_successor (i : instruction) (pc' : node) : instruction := @@ -56,5 +58,5 @@ Definition inject_at (prog : code) (pc extra_pc : node) | Some i => inject_list (PTree.set pc (alter_successor i extra_pc) prog) extra_pc (successor i) l - | None => inject_list prog extra_pc 1%positive l (* does not happen *) + | None => inject_list prog extra_pc 1 l (* does not happen *) end. -- cgit From bae72eeffdd23c3444a097f5f901333c6c70af8b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 10:59:38 +0200 Subject: more on injection --- backend/Inject.v | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/backend/Inject.v b/backend/Inject.v index 66ef9ce8..a3f2b343 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -60,3 +60,13 @@ Definition inject_at (prog : code) (pc extra_pc : node) extra_pc (successor i) l | None => inject_list prog extra_pc 1 l (* does not happen *) end. + +Definition inject_at' (already : node * code) pc l := + let (extra_pc, prog) := already in + inject_at prog pc extra_pc l. + +Definition inject' (prog : code) (extra_pc : node) (injections : PTree.t (list inj_instr)) := + PTree.fold inject_at' injections (extra_pc, prog). + +Definition inject prog extra_pc injections : code := + snd (inject' prog extra_pc injections). -- cgit From 46b9d0b4e7b37609ec62969af7354967f19e8822 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 11:49:47 +0200 Subject: preservation lemmas --- backend/Injectproof.v | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 155 insertions(+) create mode 100644 backend/Injectproof.v diff --git a/backend/Injectproof.v b/backend/Injectproof.v new file mode 100644 index 00000000..b7bc4e64 --- /dev/null +++ b/backend/Injectproof.v @@ -0,0 +1,155 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. +Require Import Inject. +Require Import Lia. + +Local Open Scope positive. + +Lemma inject_list_preserves: + forall l prog pc dst pc0, + pc0 < pc -> + PTree.get pc0 (snd (inject_list prog pc dst l)) = PTree.get pc0 prog. +Proof. + induction l; intros; simpl. + - apply PTree.gso. lia. + - rewrite IHl by lia. + apply PTree.gso. lia. +Qed. + +Fixpoint pos_add_nat x n := + match n with + | O => x + | S n' => Pos.succ (pos_add_nat x n') + end. + +Lemma pos_add_nat_increases : forall x n, x <= (pos_add_nat x n). +Proof. + induction n; simpl; lia. +Qed. + +Lemma pos_add_nat_succ : forall n x, + Pos.succ (pos_add_nat x n) = pos_add_nat (Pos.succ x) n. +Proof. + induction n; simpl; intros; trivial. + rewrite IHn. + reflexivity. +Qed. + +Lemma inject_list_increases: + forall l prog pc dst, + (fst (inject_list prog pc dst l)) = pos_add_nat pc (S (List.length l)). +Proof. + induction l; simpl; intros; trivial. + rewrite IHl. + simpl. + rewrite <- pos_add_nat_succ. + reflexivity. +Qed. + +Lemma inject_at_preserves : + forall prog pc extra_pc l pc0, + pc0 < extra_pc -> + pc0 <> pc -> + PTree.get pc0 (snd (inject_at prog pc extra_pc l)) = PTree.get pc0 prog. +Proof. + intros. unfold inject_at. + destruct (PTree.get pc prog) eqn:GET. + - rewrite inject_list_preserves; trivial. + apply PTree.gso; lia. + - apply inject_list_preserves; trivial. +Qed. + +Lemma inject_at_redirects: + forall prog pc extra_pc l i, + pc < extra_pc -> + PTree.get pc prog = Some i -> + PTree.get pc (snd (inject_at prog pc extra_pc l)) = + Some (alter_successor i extra_pc). +Proof. + intros until i. intros BEFORE GET. unfold inject_at. + rewrite GET. + rewrite inject_list_preserves by trivial. + apply PTree.gss. +Qed. + +Lemma inject_at_redirects_none: + forall prog pc extra_pc l, + pc < extra_pc -> + PTree.get pc prog = None -> + PTree.get pc (snd (inject_at prog pc extra_pc l)) = None. +Proof. + intros until l. intros BEFORE GET. unfold inject_at. + rewrite GET. + rewrite inject_list_preserves by trivial. + assumption. +Qed. + +Lemma inject_at_increases: + forall prog pc extra_pc l, + (fst (inject_at prog pc extra_pc l)) = pos_add_nat extra_pc (S (List.length l)). +Proof. + intros. unfold inject_at. + destruct (PTree.get pc prog). + all: apply inject_list_increases. +Qed. + +Definition inject_l (prog : code) extra_pc injections := + List.fold_left (fun already (injection : node * (list inj_instr)) => + inject_at' already (fst injection) (snd injection)) + injections + (extra_pc, prog). + +Lemma pair_expand: + forall { A B : Type } (p : A*B), + p = ((fst p), (snd p)). +Proof. + destruct p; simpl; trivial. +Qed. + +Lemma inject_l_preserves : + forall injections prog extra_pc pc0, + pc0 < extra_pc -> + List.forallb (fun injection => if peq (fst injection) pc0 then false else true) injections = true -> + PTree.get pc0 (snd (inject_l prog extra_pc injections)) = PTree.get pc0 prog. +Proof. + induction injections; + intros until pc0; intros BEFORE ALL; simpl; trivial. + unfold inject_l. + destruct a as [pc l]. simpl. + simpl in ALL. + rewrite andb_true_iff in ALL. + destruct ALL as [NEQ ALL]. + rewrite pair_expand with (p := inject_at prog pc extra_pc l). + fold (inject_l (snd (inject_at prog pc extra_pc l)) + (fst (inject_at prog pc extra_pc l)) + injections). + rewrite IHinjections; trivial. + - apply inject_at_preserves; trivial. + destruct (peq pc pc0); congruence. + - rewrite inject_at_increases. + pose proof (pos_add_nat_increases extra_pc (S (Datatypes.length l))). + lia. +Qed. + +Lemma inject'_preserves : + forall injections prog extra_pc pc0, + pc0 < extra_pc -> + PTree.get pc0 injections = None -> + PTree.get pc0 (snd (inject' prog extra_pc injections)) = PTree.get pc0 prog. +Proof. + intros. unfold inject'. + rewrite PTree.fold_spec. + change (fold_left + (fun (a : node * code) (p : positive * list inj_instr) => + inject_at' a (fst p) (snd p)) (PTree.elements injections) + (extra_pc, prog)) with (inject_l prog extra_pc (PTree.elements injections)). + apply inject_l_preserves; trivial. + rewrite List.forallb_forall. + intros injection IN. + destruct injection as [pc l]. + simpl. + apply PTree.elements_complete in IN. + destruct (peq pc pc0); trivial. + congruence. +Qed. -- cgit From a117ebbcb63ef0d73772e0073f23238a5642723a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 14:26:25 +0200 Subject: injector injects.. --- backend/Injectproof.v | 69 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index b7bc4e64..7a991a8c 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -47,6 +47,65 @@ Proof. reflexivity. Qed. +Program Fixpoint bounded_nth + {T : Type} (k : nat) (l : list T) (BOUND : (k < List.length l)%nat) : T := + match k, l with + | O, h::_ => h + | (S k'), _::l' => bounded_nth k' l' _ + | _, nil => _ + end. +Obligation 1. +Proof. + simpl in BOUND. + lia. +Qed. +Obligation 2. +Proof. + simpl in BOUND. + lia. +Qed. + +Program Definition bounded_nth_S_statement : Prop := + forall {T : Type} (k : nat) (h : T) (l : list T) (BOUND : (k < List.length l)%nat), + bounded_nth (S k) (h::l) _ = bounded_nth k l BOUND. +Obligation 1. +lia. +Qed. + +Lemma bounded_nth_proof_irr : + forall {T : Type} (k : nat) (l : list T) + (BOUND1 BOUND2 : (k < List.length l)%nat), + (bounded_nth k l BOUND1) = (bounded_nth k l BOUND2). +Proof. + induction k; destruct l; simpl; intros; trivial; lia. +Qed. + +Lemma bounded_nth_S : bounded_nth_S_statement. +Proof. + unfold bounded_nth_S_statement. + induction k; destruct l; simpl; intros; trivial. + 1, 2: lia. + apply bounded_nth_proof_irr. +Qed. + +Lemma inject_list_injected: + forall l prog pc dst k (BOUND : (k < (List.length l))%nat), + PTree.get (pos_add_nat pc k) (snd (inject_list prog pc dst l)) = + Some (inject_instr (bounded_nth k l BOUND) (Pos.succ (pos_add_nat pc k))). +Proof. + induction l; simpl; intros. + - lia. + - simpl. + destruct k as [ | k]. + + admit. + + simpl pos_add_nat. + rewrite pos_add_nat_succ. + erewrite IHl. + f_equal. f_equal. + simpl. + apply bounded_nth_proof_irr. +Qed. + Lemma inject_at_preserves : forall prog pc extra_pc l pc0, pc0 < extra_pc -> @@ -153,3 +212,13 @@ Proof. destruct (peq pc pc0); trivial. congruence. Qed. + +Lemma inject_preserves : + forall injections prog extra_pc pc0, + pc0 < extra_pc -> + PTree.get pc0 injections = None -> + PTree.get pc0 (inject prog extra_pc injections) = PTree.get pc0 prog. +Proof. + unfold inject'. + apply inject'_preserves. +Qed. -- cgit From d1adc4858ec70963233945542b717fcd1459a96a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 14:33:35 +0200 Subject: injector injects the end --- backend/Injectproof.v | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 7a991a8c..eeaadb2a 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -96,16 +96,31 @@ Proof. induction l; simpl; intros. - lia. - simpl. - destruct k as [ | k]. - + admit. - + simpl pos_add_nat. - rewrite pos_add_nat_succ. + destruct k as [ | k]; simpl pos_add_nat. + + simpl bounded_nth. + rewrite inject_list_preserves by lia. + apply PTree.gss. + + rewrite pos_add_nat_succ. erewrite IHl. f_equal. f_equal. simpl. apply bounded_nth_proof_irr. + Unshelve. + lia. Qed. +Lemma inject_list_injected_end: + forall l prog pc dst, + PTree.get (pos_add_nat pc (List.length l)) + (snd (inject_list prog pc dst l)) = + Some (Inop dst). +Proof. + induction l; simpl; intros. + - apply PTree.gss. + - rewrite pos_add_nat_succ. + apply IHl. +Qed. + Lemma inject_at_preserves : forall prog pc extra_pc l pc0, pc0 < extra_pc -> -- cgit From 020f1dfa53642fa452f73cbe71103572c2cc2cea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 14:55:49 +0200 Subject: inject_at injects the end --- backend/Injectproof.v | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index eeaadb2a..a568d519 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -168,11 +168,26 @@ Proof. all: apply inject_list_increases. Qed. -Definition inject_l (prog : code) extra_pc injections := - List.fold_left (fun already (injection : node * (list inj_instr)) => - inject_at' already (fst injection) (snd injection)) - injections - (extra_pc, prog). +Lemma inject_at_injected: + forall l prog pc extra_pc k (BOUND : (k < (List.length l))%nat), + PTree.get (pos_add_nat extra_pc k) (snd (inject_at prog pc extra_pc l)) = + Some (inject_instr (bounded_nth k l BOUND) (Pos.succ (pos_add_nat extra_pc k))). +Proof. + intros. unfold inject_at. + destruct (prog ! pc); apply inject_list_injected. +Qed. + +Lemma inject_at_injected_end: + forall l prog pc extra_pc i, + PTree.get pc prog = Some i -> + PTree.get (pos_add_nat extra_pc (List.length l)) + (snd (inject_at prog pc extra_pc l)) = + Some (Inop (successor i)). +Proof. + intros until i. intro REW. unfold inject_at. + rewrite REW. + apply inject_list_injected_end. +Qed. Lemma pair_expand: forall { A B : Type } (p : A*B), @@ -181,6 +196,12 @@ Proof. destruct p; simpl; trivial. Qed. +Definition inject_l (prog : code) extra_pc injections := + List.fold_left (fun already (injection : node * (list inj_instr)) => + inject_at' already (fst injection) (snd injection)) + injections + (extra_pc, prog). + Lemma inject_l_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> -- cgit From 4c65d76a7b00c01f812db3e1464fec4ecb5562c5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 15:20:10 +0200 Subject: injection positions are ok --- backend/Injectproof.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index a568d519..838230e4 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -196,12 +196,36 @@ Proof. destruct p; simpl; trivial. Qed. +Fixpoint inject_l_position extra_pc + (injections : list (node * (list inj_instr))) : node := + match injections with + | nil => extra_pc + | (pc,l)::t => inject_l_position + (Pos.succ (pos_add_nat extra_pc (List.length l))) t + end. + Definition inject_l (prog : code) extra_pc injections := List.fold_left (fun already (injection : node * (list inj_instr)) => inject_at' already (fst injection) (snd injection)) injections (extra_pc, prog). +Lemma inject_l_position_ok: + forall injections prog extra_pc, + (fst (inject_l prog extra_pc injections)) = + inject_l_position extra_pc injections. +Proof. + induction injections; intros; simpl; trivial. + destruct a as [pc l]. + unfold inject_l. simpl. + rewrite (pair_expand (inject_at prog pc extra_pc l)). + fold (inject_l (snd (inject_at prog pc extra_pc l)) (fst (inject_at prog pc extra_pc l)) injections). + rewrite IHinjections. + f_equal. + rewrite inject_at_increases. + reflexivity. +Qed. + Lemma inject_l_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> -- cgit From a4fcfbeb5bdef46b41f2a553fff72d98ea38629b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 16:26:54 +0200 Subject: injection positions.. --- backend/Injectproof.v | 53 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 4 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 838230e4..41bbd028 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -197,11 +197,17 @@ Proof. Qed. Fixpoint inject_l_position extra_pc - (injections : list (node * (list inj_instr))) : node := + (injections : list (node * (list inj_instr))) + (k : nat) {struct injections} : node := match injections with | nil => extra_pc - | (pc,l)::t => inject_l_position - (Pos.succ (pos_add_nat extra_pc (List.length l))) t + | (pc,l)::l' => + match k with + | O => extra_pc + | S k' => + inject_l_position + (Pos.succ (pos_add_nat extra_pc (List.length l))) l' k' + end end. Definition inject_l (prog : code) extra_pc injections := @@ -210,6 +216,7 @@ Definition inject_l (prog : code) extra_pc injections := injections (extra_pc, prog). +(* Lemma inject_l_position_ok: forall injections prog extra_pc, (fst (inject_l prog extra_pc injections)) = @@ -225,7 +232,7 @@ Proof. rewrite inject_at_increases. reflexivity. Qed. - +*) Lemma inject_l_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> @@ -251,6 +258,44 @@ Proof. lia. Qed. +Lemma nth_error_nil : forall { T : Type} k, + nth_error (@nil T) k = None. +Proof. + destruct k; simpl; trivial. +Qed. + +Lemma inject_l_injected: + forall injections prog injnum pc l extra_pc k + (NUMBER : nth_error injections injnum = Some (pc, l)) + (BOUND : (k < (List.length l))%nat), + PTree.get (pos_add_nat (inject_l_position extra_pc injections injnum) k) + (snd (inject_l prog extra_pc injections)) = + Some (inject_instr (bounded_nth k l BOUND) + (Pos.succ (pos_add_nat (inject_l_position extra_pc injections injnum) k))). +Proof. + induction injections; intros. + { rewrite nth_error_nil in NUMBER. + discriminate NUMBER. + } + unfold inject_l. + destruct a as [pc' l']. + simpl fold_left. + rewrite pair_expand with (p := inject_at prog pc' extra_pc l'). + progress fold (inject_l (snd (inject_at prog pc' extra_pc l')) + (fst (inject_at prog pc' extra_pc l')) + injections). + destruct injnum as [ | injnum']; simpl in NUMBER. + { inv NUMBER. + rewrite inject_l_preserves; simpl. + - apply inject_at_injected. + - rewrite inject_at_increases. + simpl. + } + rewrite <- IHinjections. + + destruct (prog ! pc); apply inject_list_injected. +Qed. + Lemma inject'_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> -- cgit From 94e9e486b3bf1dfe6dc095973709b1716d07515d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 16:50:55 +0200 Subject: inject_l injected --- backend/Injectproof.v | 47 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 43 insertions(+), 4 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 41bbd028..a805aa3e 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -36,6 +36,21 @@ Proof. reflexivity. Qed. +Lemma pos_add_nat_monotone : forall x n1 n2, + (n1 < n2) % nat -> + (pos_add_nat x n1) < (pos_add_nat x n2). +Proof. + induction n1; destruct n2; intros. + - lia. + - simpl. + pose proof (pos_add_nat_increases x n2). + lia. + - lia. + - simpl. + specialize IHn1 with n2. + lia. +Qed. + Lemma inject_list_increases: forall l prog pc dst, (fst (inject_list prog pc dst l)) = pos_add_nat pc (S (List.length l)). @@ -266,6 +281,7 @@ Qed. Lemma inject_l_injected: forall injections prog injnum pc l extra_pc k + (BELOW : forallb (fun injection => (fst injection) Date: Mon, 30 Mar 2020 17:40:54 +0200 Subject: inject_l injected_end --- backend/Injectproof.v | 90 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index a805aa3e..f048bfb9 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -335,6 +335,96 @@ Proof. lia. Qed. +Lemma inject_l_injected_end: + forall injections prog injnum pc i l extra_pc + (BEFORE : PTree.get pc prog = Some i) + (DISTINCT : list_norepet (map fst injections)) + (BELOW : forallb (fun injection => (fst injection) -- cgit From b937a4c10226930b7109ae6c9707255e53a0dd2b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 18:27:23 +0200 Subject: inject_l_redirects --- backend/Injectproof.v | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index f048bfb9..b0dcfad5 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -425,6 +425,88 @@ Proof. } Qed. + +Lemma inject_l_redirects: + forall injections prog injnum pc i l extra_pc + (BEFORE : PTree.get pc prog = Some i) + (DISTINCT : list_norepet (map fst injections)) + (BELOW : forallb (fun injection => (fst injection) -- cgit From 27c8e10f4e0a3eee6bf9feb03d0f12990f74badd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 18:46:50 +0200 Subject: use inject_l --- Makefile | 2 +- backend/Inject.v | 7 +++++++ backend/Injectproof.v | 21 +++------------------ 3 files changed, 11 insertions(+), 19 deletions(-) diff --git a/Makefile b/Makefile index 4cf9ccf1..f005d048 100644 --- a/Makefile +++ b/Makefile @@ -86,7 +86,7 @@ BACKEND=\ Kildall.v Liveness.v \ ValueDomain.v ValueAOp.v ValueAnalysis.v \ ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \ - Inject.v \ + Inject.v Injectproof.v \ CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ diff --git a/backend/Inject.v b/backend/Inject.v index a3f2b343..6799ec8a 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -65,8 +65,15 @@ Definition inject_at' (already : node * code) pc l := let (extra_pc, prog) := already in inject_at prog pc extra_pc l. +Definition inject_l (prog : code) extra_pc injections := + List.fold_left (fun already (injection : node * (list inj_instr)) => + inject_at' already (fst injection) (snd injection)) + injections + (extra_pc, prog). +(* Definition inject' (prog : code) (extra_pc : node) (injections : PTree.t (list inj_instr)) := PTree.fold inject_at' injections (extra_pc, prog). Definition inject prog extra_pc injections : code := snd (inject' prog extra_pc injections). +*) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index b0dcfad5..80b217bc 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -81,7 +81,7 @@ Proof. Qed. Program Definition bounded_nth_S_statement : Prop := - forall {T : Type} (k : nat) (h : T) (l : list T) (BOUND : (k < List.length l)%nat), + forall (T : Type) (k : nat) (h : T) (l : list T) (BOUND : (k < List.length l)%nat), bounded_nth (S k) (h::l) _ = bounded_nth k l BOUND. Obligation 1. lia. @@ -231,23 +231,6 @@ Definition inject_l (prog : code) extra_pc injections := injections (extra_pc, prog). -(* -Lemma inject_l_position_ok: - forall injections prog extra_pc, - (fst (inject_l prog extra_pc injections)) = - inject_l_position extra_pc injections. -Proof. - induction injections; intros; simpl; trivial. - destruct a as [pc l]. - unfold inject_l. simpl. - rewrite (pair_expand (inject_at prog pc extra_pc l)). - fold (inject_l (snd (inject_at prog pc extra_pc l)) (fst (inject_at prog pc extra_pc l)) injections). - rewrite IHinjections. - f_equal. - rewrite inject_at_increases. - reflexivity. -Qed. -*) Lemma inject_l_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> @@ -507,6 +490,7 @@ Proof. } Qed. +(* Lemma inject'_preserves : forall injections prog extra_pc pc0, pc0 < extra_pc -> @@ -538,3 +522,4 @@ Proof. unfold inject'. apply inject'_preserves. Qed. +*) -- cgit From 3655a7585c925c0bb5825a8b65bec3d8323ad3b6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 19:20:24 +0200 Subject: injector wrapper function --- backend/Inject.v | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/backend/Inject.v b/backend/Inject.v index 6799ec8a..e65cb060 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -77,3 +77,25 @@ Definition inject' (prog : code) (extra_pc : node) (injections : PTree.t (list i Definition inject prog extra_pc injections : code := snd (inject' prog extra_pc injections). *) + +Section INJECTOR. + Variable gen_injections : function -> PTree.t (list inj_instr). + + Definition transf_function (f : function) : res function := + let injections := PTree.elements (gen_injections f) in + let max_pc := max_pc_function f in + if List.forallb (fun injection => (fst injection) <=? max_pc) injections + then + OK {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := snd (inject_l (fn_code f) (Pos.succ max_pc) injections); + fn_entrypoint := f.(fn_entrypoint) |} + else Error (msg "Inject.transf_function: injections at bad locations"). + +Definition transf_fundef (fd: fundef) : res fundef := + AST.transf_partial_fundef transf_function fd. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. +End INJECTOR. -- cgit From cc2518fa3ace7e1a74f3717434fc6daebea522fa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 19:49:57 +0200 Subject: more proofs on injector --- backend/Injectproof.v | 174 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 173 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 80b217bc..05c57569 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1,6 +1,6 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. -Require Import Memory Registers Op RTL. +Require Import Memory Registers Op RTL Globalenvs Values. Require Import Inject. Require Import Lia. @@ -523,3 +523,175 @@ Proof. apply inject'_preserves. Qed. *) + +Section INJECTOR. + Variable gen_injections : function -> PTree.t (list inj_instr). + + Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => transf_fundef gen_injections f = OK tf) eq p tp. + + Lemma transf_program_match: + forall p tp, transf_program gen_injections p = OK tp -> match_prog p tp. + Proof. + intros. eapply match_transform_partial_program; eauto. + Qed. + + Section PRESERVATION. + + Variables prog tprog: program. + Hypothesis TRANSF: match_prog prog tprog. + Let ge := Genv.globalenv prog. + Let tge := Genv.globalenv tprog. + + Definition match_regs (f : function) (rs rs' : regset) := + forall r, r <= max_reg_function f -> (rs'#r = rs#r). + + Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := + | match_frames_intro: forall res f tf sp pc rs trs + (FUN : transf_function gen_injections f = OK tf) + (REGS : match_regs f rs trs), + match_frames (Stackframe res f sp pc rs) + (Stackframe res tf sp pc trs). + + Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s f tf sp pc rs trs m ts + (FUN : transf_function gen_injections f = OK tf) + (STACKS: list_forall2 match_frames s ts) + (REGS: match_regs f rs trs), + match_states (State s f sp pc rs m) (State ts tf sp pc trs m) + | match_states_call: + forall s fd tfd args m ts + (FUN : transf_fundef gen_injections fd = OK tfd) + (STACKS: list_forall2 match_frames s ts), + match_states (Callstate s fd args m) (Callstate ts tfd args m) + | match_states_return: + forall s res m ts + (STACKS: list_forall2 match_frames s ts), + match_states (Returnstate s res m) + (Returnstate ts res m). + + Lemma functions_translated: + forall (v: val) (f: RTL.fundef), + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ + transf_fundef gen_injections f = OK tf. + Proof. + apply (Genv.find_funct_transf_partial TRANSF). + Qed. + + Lemma function_ptr_translated: + forall (b: block) (f: RTL.fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ + transf_fundef gen_injections f = OK tf. + Proof. + apply (Genv.find_funct_ptr_transf_partial TRANSF). + Qed. + + Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. + Proof. + apply (Genv.find_symbol_match TRANSF). + Qed. + + Lemma senv_preserved: + Senv.equiv ge tge. + Proof. + apply (Genv.senv_match TRANSF). + Qed. + + Lemma sig_preserved: + forall f tf, transf_fundef gen_injections f = OK tf + -> funsig tf = funsig f. + Proof. + destruct f; simpl; intros; monadInv H; trivial. + unfold transf_function in *. + destruct forallb in EQ. + 2: discriminate. + inv EQ. + reflexivity. + Qed. + + Lemma stacksize_preserved: + forall f tf, transf_function gen_injections f = OK tf -> + fn_stacksize tf = fn_stacksize f. + Proof. + destruct f. + unfold transf_function. + intros. + destruct forallb in H. + 2: discriminate. + inv H. + reflexivity. + Qed. + + Lemma params_preserved: + forall f tf, transf_function gen_injections f = OK tf -> + fn_params tf = fn_params f. + Proof. + destruct f. + unfold transf_function. + intros. + destruct forallb in H. + 2: discriminate. + inv H. + reflexivity. + Qed. + + Lemma entrypoint_preserved: + forall f tf, transf_function gen_injections f = OK tf -> + fn_entrypoint tf = fn_entrypoint f. + Proof. + destruct f. + unfold transf_function. + intros. + destruct forallb in H. + 2: discriminate. + inv H. + reflexivity. + Qed. + + Lemma sig_preserved2: + forall f tf, transf_function gen_injections f = OK tf -> + fn_sig tf = fn_sig f. + Proof. + destruct f. + unfold transf_function. + intros. + destruct forallb in H. + 2: discriminate. + inv H. + reflexivity. + Qed. + + Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. + Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. + intros (tf & A & B). + exists (Callstate nil tf nil m0); split. + - econstructor; eauto. + + eapply (Genv.init_mem_match TRANSF); eauto. + + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + symmetry. eapply match_program_main; eauto. + + rewrite <- H3. eapply sig_preserved; eauto. + - constructor; trivial. + constructor. + Qed. + + Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> + final_state S1 r -> final_state S2 r. + Proof. + intros. inv H0. inv H. inv STACKS. constructor. + Qed. + +End PRESERVATION. +End INJECTOR. -- cgit From 3d4806d52f65099192adc34a2c6b2c5979537fd3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 20:11:36 +0200 Subject: additional checks --- backend/Inject.v | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/backend/Inject.v b/backend/Inject.v index e65cb060..6da10019 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -84,7 +84,17 @@ Section INJECTOR. Definition transf_function (f : function) : res function := let injections := PTree.elements (gen_injections f) in let max_pc := max_pc_function f in - if List.forallb (fun injection => (fst injection) <=? max_pc) injections + let max_reg := max_reg_function f in + if List.forallb + (fun injection => + ((fst injection) <=? max_pc) && + (List.forallb + (fun (i : inj_instr) => + (match i with + | INJop _ _ res => res + | INJload _ _ _ res => res + end) <=? max_reg) (snd injection)) + ) injections then OK {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); -- cgit From a779d35bad9faf3bbfc5bf898565256bd40edf33 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 30 Mar 2020 22:17:12 +0200 Subject: lemma on stepping through non trapping instructions --- backend/Inject.v | 28 ++++++++----- backend/Injectproof.v | 106 +++++++++++++++++++++++++++++++++++++++++++++++--- mppa_k1c/Op.v | 11 ++++-- 3 files changed, 126 insertions(+), 19 deletions(-) diff --git a/backend/Inject.v b/backend/Inject.v index 6da10019..6ef32ccb 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -81,20 +81,28 @@ Definition inject prog extra_pc injections : code := Section INJECTOR. Variable gen_injections : function -> PTree.t (list inj_instr). + Definition valid_injection_instr (max_reg : reg) (i : inj_instr) := + match i with + | INJop op args res => (max_reg max_reg + ((fst injection) <=? max_pc) && + (List.forallb (valid_injection_instr max_reg) (snd injection)) + ). + + Definition valid_injections f := + valid_injections1 (max_pc_function f) (max_reg_function f). + Definition transf_function (f : function) : res function := let injections := PTree.elements (gen_injections f) in let max_pc := max_pc_function f in let max_reg := max_reg_function f in - if List.forallb - (fun injection => - ((fst injection) <=? max_pc) && - (List.forallb - (fun (i : inj_instr) => - (match i with - | INJop _ _ res => res - | INJload _ _ _ res => res - end) <=? max_reg) (snd injection)) - ) injections + if valid_injections1 max_pc max_reg injections then OK {| fn_sig := f.(fn_sig); fn_params := f.(fn_params); diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 05c57569..e3c9007b 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1,6 +1,6 @@ Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. -Require Import Memory Registers Op RTL Globalenvs Values. +Require Import Memory Registers Op RTL Globalenvs Values Events. Require Import Inject. Require Import Lia. @@ -545,6 +545,11 @@ Section INJECTOR. Definition match_regs (f : function) (rs rs' : regset) := forall r, r <= max_reg_function f -> (rs'#r = rs#r). + + Lemma match_regs_refl : forall f rs, match_regs f rs rs. + Proof. + unfold match_regs. intros. trivial. + Qed. Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f tf sp pc rs trs @@ -610,7 +615,7 @@ Section INJECTOR. Proof. destruct f; simpl; intros; monadInv H; trivial. unfold transf_function in *. - destruct forallb in EQ. + destruct valid_injections1 in EQ. 2: discriminate. inv EQ. reflexivity. @@ -623,7 +628,7 @@ Section INJECTOR. destruct f. unfold transf_function. intros. - destruct forallb in H. + destruct valid_injections1 in H. 2: discriminate. inv H. reflexivity. @@ -636,7 +641,7 @@ Section INJECTOR. destruct f. unfold transf_function. intros. - destruct forallb in H. + destruct valid_injections1 in H. 2: discriminate. inv H. reflexivity. @@ -649,7 +654,7 @@ Section INJECTOR. destruct f. unfold transf_function. intros. - destruct forallb in H. + destruct valid_injections1 in H. 2: discriminate. inv H. reflexivity. @@ -662,7 +667,7 @@ Section INJECTOR. destruct f. unfold transf_function. intros. - destruct forallb in H. + destruct valid_injections1 in H. 2: discriminate. inv H. reflexivity. @@ -693,5 +698,94 @@ Section INJECTOR. intros. inv H0. inv H. inv STACKS. constructor. Qed. + Lemma assign_above: + forall f trs res v, + (max_reg_function f) < res -> + match_regs f trs trs # res <- v. + Proof. + unfold match_regs. + intros. + apply Regmap.gso. + lia. + Qed. + + Lemma transf_function_inj_step: + forall ts f tf sp pc trs m ii + (FUN : transf_function gen_injections f = OK tf) + (GET : (fn_code tf) ! pc = Some (inject_instr ii (Pos.succ pc))) + (VALID : valid_injection_instr (max_reg_function f) ii = true), + exists trs', + RTL.step ge + (State ts tf sp pc trs m) E0 + (State ts tf sp (Pos.succ pc) trs' m) /\ + match_regs (f : function) trs trs'. + Proof. + destruct ii as [op args res | chunk addr args res]; simpl; intros. + - repeat rewrite andb_true_iff in VALID. + rewrite negb_true_iff in VALID. + destruct VALID as (MAX_REG & NOTRAP & LENGTH). + rewrite Pos.ltb_lt in MAX_REG. + rewrite Nat.eqb_eq in LENGTH. + destruct (eval_operation ge sp op trs ## args m) as [v | ] eqn:EVAL. + + exists (trs # res <- v). + split. + * apply exec_Iop with (op := op) (args := args) (res := res); assumption. + * apply assign_above; auto. + + exfalso. + generalize EVAL. + apply is_trapping_op_sound; trivial. + rewrite map_length. + assumption. + - rewrite Pos.ltb_lt in VALID. + destruct (eval_addressing ge sp addr trs ## args) as [a | ] eqn:ADDR. + + destruct (Mem.loadv chunk m a) as [v | ] eqn:LOAD. + * exists (trs # res <- v). + split. + ** apply exec_Iload with (trap := NOTRAP) (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); assumption. + ** apply assign_above; auto. + * exists (trs # res <- Vundef). + split. + ** apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); assumption. + ** apply assign_above; auto. + + exists (trs # res <- Vundef). + split. + * apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args) (dst := res); assumption. + * apply assign_above; auto. + Qed. + + (* TODO + Lemma transf_function_starstep : + forall ts f tf sp m inj_n src_pc inj_pc inj_code + (FUN : transf_function gen_injections f = OK tf) + (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + Some (src_pc, inj_code)) + (POSITION : inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) inj_n = inj_pc) + (k : nat) + (CUR : (k <= (List.length inj_code))%nat) + (trs : regset), + exists trs', + match_regs (f : function) trs trs' /\ + Smallstep.star RTL.step ge + (State ts tf sp (pos_add_nat inj_pc + ((List.length inj_code) - k)%nat) trs m) E0 + (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs' m). + Proof. + induction k; simpl; intros. + { rewrite Nat.sub_0_r. + exists trs. + split. + - apply match_regs_refl. + - constructor. + } + assert (k <= Datatypes.length inj_code)%nat as KK by lia. + pose proof (IHk KK) as IH. + clear IHk KK. + assert ( + exists trs'. + split. + assumption. +*) + End PRESERVATION. End INJECTOR. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 92061d04..4caac9e1 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1045,14 +1045,19 @@ Definition is_trapping_op (op : operation) := | _ => false end. +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). -- cgit From 1ba9cba60f5cf4fe0a2c1d620881cad2383c0027 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 00:34:14 +0200 Subject: one more admit --- backend/Injectproof.v | 92 +++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 85 insertions(+), 7 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index e3c9007b..c3de5e47 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -225,6 +225,19 @@ Fixpoint inject_l_position extra_pc end end. +Lemma inject_l_position_increases : forall injections pc k, + pc <= inject_l_position pc injections k. +Proof. + induction injections; simpl; intros. + lia. + destruct a as [_ l]. + destruct k. + lia. + specialize IHinjections with (pc := (Pos.succ (pos_add_nat pc (Datatypes.length l)))) (k := k). + assert (pc <= (pos_add_nat pc (Datatypes.length l))) by apply pos_add_nat_increases. + lia. +Qed. + Definition inject_l (prog : code) extra_pc injections := List.fold_left (fun already (injection : node * (list inj_instr)) => inject_at' already (fst injection) (snd injection)) @@ -550,6 +563,15 @@ Section INJECTOR. Proof. unfold match_regs. intros. trivial. Qed. + + Lemma match_regs_trans : forall f rs1 rs2 rs3, + match_regs f rs1 rs2 -> match_regs f rs2 rs3 -> match_regs f rs1 rs3. + Proof. + unfold match_regs. intros until rs3. intros M12 M23 r. + specialize M12 with r. + specialize M23 with r. + intuition congruence. + Qed. Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f tf sp pc rs trs @@ -753,8 +775,7 @@ Section INJECTOR. * apply assign_above; auto. Qed. - (* TODO - Lemma transf_function_starstep : + Lemma transf_function_inj_starstep : forall ts f tf sp m inj_n src_pc inj_pc inj_code (FUN : transf_function gen_injections f = OK tf) (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = @@ -781,11 +802,68 @@ Section INJECTOR. assert (k <= Datatypes.length inj_code)%nat as KK by lia. pose proof (IHk KK) as IH. clear IHk KK. - assert ( - exists trs'. - split. - assumption. -*) + pose proof FUN as VALIDATE. + unfold transf_function, valid_injections1 in VALIDATE. + destruct forallb eqn:FORALL in VALIDATE. + 2: discriminate. + injection VALIDATE. + intro TF. + symmetry in TF. + pose proof (inject_l_injected (PTree.elements (gen_injections f)) (fn_code f) inj_n src_pc inj_code (Pos.succ (max_pc_function f)) ((List.length inj_code) - (S k))%nat) as INJECTED. + lapply INJECTED. + { clear INJECTED. + intro INJECTED. + assert ((Datatypes.length inj_code - S k < + Datatypes.length inj_code)%nat) as LESS by lia. + pose proof (INJECTED INJ LESS) as INJ'. + replace (snd + (inject_l (fn_code f) (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)))) with (fn_code tf) in INJ'. + 2: rewrite TF; simpl; reflexivity. apply transf_function_inj_step with (f:=f) (ts:=ts) (sp:=sp) (trs:=trs) (m := m) in INJ'. + 2: assumption. + { + destruct INJ' as [trs'' [STEP STEPMATCH]]. + destruct (IH trs'') as [trs' [STARSTEPMATCH STARSTEP]]. + exists trs'. + split. + { apply match_regs_trans with (rs2 := trs''); assumption. } + eapply Smallstep.star_step with (t1:=E0) (t2:=E0). + { + rewrite POSITION in STEP. + exact STEP. + } + { + replace (Datatypes.length inj_code - k)%nat + with (S (Datatypes.length inj_code - (S k)))%nat in STARSTEP by lia. + simpl pos_add_nat in STARSTEP. + exact STARSTEP. + } + constructor. + } + rewrite forallb_forall in FORALL. + specialize FORALL with (src_pc, inj_code). + lapply FORALL. + { + simpl. + rewrite andb_true_iff. + intros (SRC & ALL_VALID). + rewrite forallb_forall in ALL_VALID. + apply ALL_VALID. + admit. + } + apply nth_error_In with (n := inj_n). + assumption. + } + rewrite forallb_forall in FORALL. + rewrite forallb_forall. + intros x INx. + rewrite Pos.ltb_lt. + pose proof (FORALL x INx) as ALLx. + rewrite andb_true_iff in ALLx. + destruct ALLx as [ALLx1 ALLx2]. + rewrite Pos.leb_le in ALLx1. + lia. + Admitted. End PRESERVATION. End INJECTOR. -- cgit From 2ebd2eced4437aea823442dd15f160917590cb8a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 00:45:57 +0200 Subject: injector "ghost steps" --- backend/Injectproof.v | 39 +++++++++++++++++++++++++++++++++++---- 1 file changed, 35 insertions(+), 4 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index c3de5e47..dac93d41 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -775,7 +775,17 @@ Section INJECTOR. * apply assign_above; auto. Qed. - Lemma transf_function_inj_starstep : + Lemma bounded_nth_In: forall {T : Type} (l : list T) k LESS, + In (bounded_nth k l LESS) l. + Proof. + induction l; simpl; intros. + lia. + destruct k; simpl. + - left; trivial. + - right. apply IHl. + Qed. + + Lemma transf_function_inj_starstep_rec : forall ts f tf sp m inj_n src_pc inj_pc inj_code (FUN : transf_function gen_injections f = OK tf) (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = @@ -849,7 +859,7 @@ Section INJECTOR. intros (SRC & ALL_VALID). rewrite forallb_forall in ALL_VALID. apply ALL_VALID. - admit. + apply bounded_nth_In. } apply nth_error_In with (n := inj_n). assumption. @@ -863,7 +873,28 @@ Section INJECTOR. destruct ALLx as [ALLx1 ALLx2]. rewrite Pos.leb_le in ALLx1. lia. - Admitted. - + Qed. + + Lemma transf_function_inj_starstep : + forall ts f tf sp m inj_n src_pc inj_pc inj_code + (FUN : transf_function gen_injections f = OK tf) + (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + Some (src_pc, inj_code)) + (POSITION : inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) inj_n = inj_pc) + (trs : regset), + exists trs', + match_regs (f : function) trs trs' /\ + Smallstep.star RTL.step ge + (State ts tf sp inj_pc trs m) E0 + (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs' m). + Proof. + intros. + replace (State ts tf sp inj_pc trs m) with (State ts tf sp (pos_add_nat inj_pc ((List.length inj_code) - (List.length inj_code))%nat) trs m). + eapply transf_function_inj_starstep_rec; eauto. + f_equal. + rewrite <- minus_n_n. + reflexivity. + Qed. End PRESERVATION. End INJECTOR. -- cgit From 63e2afe7ee5507a724bed691ad76fad635754882 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 11:13:38 +0200 Subject: transf_function_inj_end --- backend/Injectproof.v | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index dac93d41..c3382d72 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -896,5 +896,62 @@ Section INJECTOR. rewrite <- minus_n_n. reflexivity. Qed. + + Lemma transf_function_inj_end : + forall ts f tf sp m inj_n src_pc inj_pc inj_code i + (FUN : transf_function gen_injections f = OK tf) + (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + Some (src_pc, inj_code)) + (SRC: (fn_code f) ! src_pc = Some i) + (POSITION : inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) inj_n = inj_pc) + (trs : regset), + RTL.step ge + (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs m) E0 + (State ts tf sp (successor i) trs m). + Proof. + intros. + pose proof FUN as VALIDATE. + unfold transf_function, valid_injections1 in VALIDATE. + destruct forallb eqn:FORALL in VALIDATE. + 2: discriminate. + injection VALIDATE. + intro TF. + symmetry in TF. + Check inject_l_injected_end. + pose proof (inject_l_injected_end (PTree.elements (gen_injections f)) (fn_code f) inj_n src_pc i inj_code (Pos.succ (max_pc_function f))) as INJECTED. + lapply INJECTED. + 2: assumption. + clear INJECTED. + intro INJECTED. + lapply INJECTED. + 2: apply (PTree.elements_keys_norepet (gen_injections f)); fail. + clear INJECTED. + intro INJECTED. + lapply INJECTED. + { clear INJECTED. + intro INJECTED. + pose proof (INJECTED INJ) as INJ'. + clear INJECTED. + replace (snd + (inject_l (fn_code f) (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)))) with (fn_code tf) in INJ'. + 2: rewrite TF; simpl; reflexivity. + rewrite POSITION in INJ'. + apply exec_Inop. + assumption. + } + clear INJECTED. + rewrite forallb_forall in FORALL. + rewrite forallb_forall. + intros x INx. + rewrite Pos.ltb_lt. + pose proof (FORALL x INx) as ALLx. + rewrite andb_true_iff in ALLx. + destruct ALLx as [ALLx1 ALLx2]. + rewrite Pos.leb_le in ALLx1. + lia. + Qed. + End PRESERVATION. End INJECTOR. -- cgit From 764b167efe9edb3d0d20e8ea37263320c42f3036 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 11:22:56 +0200 Subject: transf_function_inj_plusstep --- backend/Injectproof.v | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index c3382d72..51d049b1 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -953,5 +953,30 @@ Section INJECTOR. lia. Qed. + Lemma transf_function_inj_plusstep : + forall ts f tf sp m inj_n src_pc inj_pc inj_code i + (FUN : transf_function gen_injections f = OK tf) + (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + Some (src_pc, inj_code)) + (SRC: (fn_code f) ! src_pc = Some i) + (POSITION : inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) inj_n = inj_pc) + (trs : regset), + exists trs', + match_regs (f : function) trs trs' /\ + Smallstep.plus RTL.step ge + (State ts tf sp inj_pc trs m) E0 + (State ts tf sp (successor i) trs' m). + Proof. + intros. + destruct (transf_function_inj_starstep ts f tf sp m inj_n src_pc inj_pc inj_code FUN INJ POSITION trs) as [trs' [MATCH PLUS]]. + exists trs'. + split. assumption. + eapply Smallstep.plus_right. + exact PLUS. + eapply transf_function_inj_end; eassumption. + reflexivity. + Qed. + End PRESERVATION. End INJECTOR. -- cgit From 7de591569308917c9ffcd4626c94872e390811a2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 11:49:21 +0200 Subject: INJnop --- backend/Inject.v | 3 +++ backend/Injectproof.v | 6 +++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/backend/Inject.v b/backend/Inject.v index 6ef32ccb..57aa343b 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -5,11 +5,13 @@ Require Import Memory Registers Op RTL. Local Open Scope positive. Inductive inj_instr : Type := + | INJnop | INJop: operation -> list reg -> reg -> inj_instr | INJload: memory_chunk -> addressing -> list reg -> reg -> inj_instr. Definition inject_instr (i : inj_instr) (pc' : node) : instruction := match i with + | INJnop => Inop pc' | INJop op args dst => Iop op args dst pc' | INJload chunk addr args dst => Iload NOTRAP chunk addr args dst pc' end. @@ -83,6 +85,7 @@ Section INJECTOR. Definition valid_injection_instr (max_reg : reg) (i : inj_instr) := match i with + | INJnop => true | INJop op args res => (max_reg max_reg Date: Tue, 31 Mar 2020 12:54:59 +0200 Subject: transf_function_redirects --- backend/Injectproof.v | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 109 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 7ce401cb..de60a4d6 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -981,6 +981,115 @@ Section INJECTOR. eapply transf_function_inj_end; eassumption. reflexivity. Qed. + + Lemma transf_function_preserves: + forall f tf pc + (FUN : transf_function gen_injections f = OK tf) + (LESS : pc <= max_pc_function f) + (NOCHANGE : (gen_injections f) ! pc = None), + (fn_code tf) ! pc = (fn_code f) ! pc. + Proof. + intros. + unfold transf_function in FUN. + destruct valid_injections1 in FUN. + 2: discriminate. + inv FUN. + simpl. + apply inject_l_preserves. + lia. + rewrite forallb_forall. + intros x INx. + destruct peq; trivial. + subst pc. + exfalso. + destruct x as [pc ii]. + simpl in *. + apply PTree.elements_complete in INx. + congruence. + Qed. + + Lemma transf_function_redirects: + forall f tf pc injl ii + (FUN : transf_function gen_injections f = OK tf) + (LESS : pc <= max_pc_function f) + (INJECTION : (gen_injections f) ! pc = Some injl) + (INSTR: (fn_code f) ! pc = Some ii), + exists pc' : node, + (fn_code tf) ! pc = Some (alter_successor ii pc') /\ + (forall ts sp m trs, + exists trs', + match_regs f trs trs' /\ + Smallstep.plus RTL.step ge + (State ts tf sp pc' trs m) E0 + (State ts tf sp (successor ii) trs' m)). + Proof. + intros. + apply PTree.elements_correct in INJECTION. + apply In_nth_error in INJECTION. + destruct INJECTION as [injn INJECTION]. + exists (inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) injn). + split. + { unfold transf_function in FUN. + destruct (valid_injections1) eqn:VALID in FUN. + 2: discriminate. + inv FUN. + simpl. + apply inject_l_redirects with (l := injl); auto. + apply PTree.elements_keys_norepet. + unfold valid_injections1 in VALID. + rewrite forallb_forall in VALID. + rewrite forallb_forall. + intros x INx. + pose proof (VALID x INx) as VALIDx. + clear VALID. + rewrite andb_true_iff in VALIDx. + rewrite Pos.leb_le in VALIDx. + destruct VALIDx as [VALIDx1 VALIDx2]. + rewrite Pos.ltb_lt. + lia. + } + intros. + pose proof (transf_function_inj_plusstep ts f tf sp m injn pc + (inject_l_position (Pos.succ (max_pc_function f)) + (PTree.elements (gen_injections f)) injn) + injl ii FUN INJECTION INSTR) as TRANS. + lapply TRANS. + 2: reflexivity. + clear TRANS. + intro TRANS. + exact (TRANS trs). + Qed. + + Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall ts1 (MS: match_states s1 ts1), + exists ts2, Smallstep.plus step tge ts1 t ts2 /\ match_states s2 ts2. + Proof. + induction 1; intros ts1 MS; inv MS; try (inv TRC). + - (* nop *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Inop. + ** + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Inop. + rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + * constructor; trivial. + Admitted. + Theorem transf_program_correct: + Smallstep.forward_simulation (semantics prog) (semantics tprog). + Proof. + eapply Smallstep.forward_simulation_plus. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. + Qed. + End PRESERVATION. End INJECTOR. -- cgit From 4e3a12b9d9811b7da429cb2fd0b0c986582093a2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 14:10:22 +0200 Subject: lots of admits to be filled --- backend/Injectproof.v | 147 +++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 134 insertions(+), 13 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index de60a4d6..3ed9c8b7 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -737,7 +737,7 @@ Section INJECTOR. (GET : (fn_code tf) ! pc = Some (inject_instr ii (Pos.succ pc))) (VALID : valid_injection_instr (max_reg_function f) ii = true), exists trs', - RTL.step ge + RTL.step tge (State ts tf sp pc trs m) E0 (State ts tf sp (Pos.succ pc) trs' m) /\ match_regs (f : function) trs trs'. @@ -755,7 +755,10 @@ Section INJECTOR. destruct (eval_operation ge sp op trs ## args m) as [v | ] eqn:EVAL. + exists (trs # res <- v). split. - * apply exec_Iop with (op := op) (args := args) (res := res); assumption. + * apply exec_Iop with (op := op) (args := args) (res := res); trivial. + rewrite eval_operation_preserved with (ge1 := ge). + assumption. + exact symbols_preserved. * apply assign_above; auto. + exfalso. generalize EVAL. @@ -767,15 +770,24 @@ Section INJECTOR. + destruct (Mem.loadv chunk m a) as [v | ] eqn:LOAD. * exists (trs # res <- v). split. - ** apply exec_Iload with (trap := NOTRAP) (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); assumption. + ** apply exec_Iload with (trap := NOTRAP) (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); trivial. + rewrite eval_addressing_preserved with (ge1 := ge). + assumption. + exact symbols_preserved. ** apply assign_above; auto. * exists (trs # res <- Vundef). split. - ** apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); assumption. + ** apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); trivial. + rewrite eval_addressing_preserved with (ge1 := ge). + assumption. + exact symbols_preserved. ** apply assign_above; auto. + exists (trs # res <- Vundef). split. - * apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args) (dst := res); assumption. + * apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args) (dst := res); trivial. + rewrite eval_addressing_preserved with (ge1 := ge). + assumption. + exact symbols_preserved. * apply assign_above; auto. Qed. @@ -801,7 +813,7 @@ Section INJECTOR. (trs : regset), exists trs', match_regs (f : function) trs trs' /\ - Smallstep.star RTL.step ge + Smallstep.star RTL.step tge (State ts tf sp (pos_add_nat inj_pc ((List.length inj_code) - k)%nat) trs m) E0 (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs' m). @@ -889,7 +901,7 @@ Section INJECTOR. (trs : regset), exists trs', match_regs (f : function) trs trs' /\ - Smallstep.star RTL.step ge + Smallstep.star RTL.step tge (State ts tf sp inj_pc trs m) E0 (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs' m). Proof. @@ -910,7 +922,7 @@ Section INJECTOR. (POSITION : inject_l_position (Pos.succ (max_pc_function f)) (PTree.elements (gen_injections f)) inj_n = inj_pc) (trs : regset), - RTL.step ge + RTL.step tge (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs m) E0 (State ts tf sp (successor i) trs m). Proof. @@ -968,7 +980,7 @@ Section INJECTOR. (trs : regset), exists trs', match_regs (f : function) trs trs' /\ - Smallstep.plus RTL.step ge + Smallstep.plus RTL.step tge (State ts tf sp inj_pc trs m) E0 (State ts tf sp (successor i) trs' m). Proof. @@ -1019,7 +1031,7 @@ Section INJECTOR. (forall ts sp m trs, exists trs', match_regs f trs trs' /\ - Smallstep.plus RTL.step ge + Smallstep.plus RTL.step tge (State ts tf sp pc' trs m) E0 (State ts tf sp (successor ii) trs' m)). Proof. @@ -1060,7 +1072,50 @@ Section INJECTOR. intro TRANS. exact (TRANS trs). Qed. - + + Lemma transf_function_preserves_uses: + forall f tf pc rs trs ii + (FUN : transf_function gen_injections f = OK tf) + (MATCH : match_regs f rs trs) + (INSTR : (fn_code f) ! pc = Some ii), + trs ## (instr_uses ii) = rs ## (instr_uses ii). + Proof. + intros. + assert (forall r, In r (instr_uses ii) -> + trs # r = rs # r) as SAME. + { + intros r INr. + apply MATCH. + apply (max_reg_function_use f pc ii); auto. + } + induction (instr_uses ii); simpl; trivial. + f_equal. + - apply SAME. constructor; trivial. + - apply IHl. intros. + apply SAME. right. assumption. + Qed. + + Lemma match_regs_write: + forall f rs trs res v + (MATCH : match_regs f rs trs), + match_regs f (rs # res <- v) (trs # res <- v). + Proof. + intros. + intros r LESS. + destruct (peq r res). + { + subst r. + rewrite Regmap.gss. + symmetry. + apply Regmap.gss. + } + rewrite Regmap.gso. + rewrite Regmap.gso. + all: trivial. + apply MATCH. + trivial. + Qed. + Theorem transf_step_correct: forall s1 t s2, step ge s1 t s2 -> forall ts1 (MS: match_states s1 ts1), @@ -1069,16 +1124,82 @@ Section INJECTOR. induction 1; intros ts1 MS; inv MS; try (inv TRC). - (* nop *) destruct ((gen_injections f) ! pc) eqn:INJECTION. - + econstructor; split. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. * eapply Smallstep.plus_left. ** apply exec_Inop. - ** + exact ALTER. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs); assumption. + econstructor; split. * apply Smallstep.plus_one. apply exec_Inop. rewrite transf_function_preserves with (f:=f); eauto. eapply max_pc_function_sound; eauto. * constructor; trivial. + - (* op *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) + (trs := trs # res <- v). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Iop with (op := op) (args := args). + exact ALTER. + rewrite eval_operation_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iop op args res pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. + eassumption. + } + exact symbols_preserved. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs # res <- v); trivial. + apply match_regs_write. + assumption. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Iop with (op := op) (args := args). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** rewrite eval_operation_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iop op args res pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. + eassumption. + } + exact symbols_preserved. + * constructor; trivial. + apply match_regs_write. + assumption. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. Admitted. Theorem transf_program_correct: -- cgit From 3d4acdb480ff33e09ad4a96548548f7876c4e78e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 14:21:05 +0200 Subject: loads --- backend/Injectproof.v | 129 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 126 insertions(+), 3 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 3ed9c8b7..36d3341c 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1144,6 +1144,7 @@ Section INJECTOR. rewrite transf_function_preserves with (f:=f); eauto. eapply max_pc_function_sound; eauto. * constructor; trivial. + - (* op *) destruct ((gen_injections f) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. @@ -1187,9 +1188,131 @@ Section INJECTOR. * constructor; trivial. apply match_regs_write. assumption. - - admit. - - admit. - - admit. + + - (* load *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) + (trs := trs # dst <- v). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Iload with (trap := trap) (chunk := chunk) (addr := addr) (args := args) (a := a). + exact ALTER. + rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload trap chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + eassumption. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs # dst <- v); trivial. + apply match_regs_write. + assumption. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Iload with (trap := trap) (chunk := chunk) (addr := addr) (args := args) (a := a). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload trap chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + ** eassumption. + * constructor; trivial. + apply match_regs_write. + assumption. + + - (* load notrap1 *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) + (trs := trs # dst <- Vundef). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args). + exact ALTER. + rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload NOTRAP chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs # dst <- Vundef); trivial. + apply match_regs_write. + assumption. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload NOTRAP chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + * constructor; trivial. + apply match_regs_write. + assumption. + + - (* load notrap2 *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) + (trs := trs # dst <- Vundef). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (a := a). + exact ALTER. + rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload NOTRAP chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + eassumption. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs # dst <- Vundef); trivial. + apply match_regs_write. + assumption. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (a := a). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** rewrite eval_addressing_preserved with (ge1 := ge). + { + replace args with (instr_uses (Iload NOTRAP chunk addr args dst pc')) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + ** eassumption. + * constructor; trivial. + apply match_regs_write. + assumption. + - admit. - admit. - admit. -- cgit From 468b01d591a4fb03c7660c8cda1953414bc9b8bc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 14:30:58 +0200 Subject: store --- backend/Injectproof.v | 43 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 36d3341c..b2ea2562 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1313,7 +1313,48 @@ Section INJECTOR. apply match_regs_write. assumption. - - admit. + - (* store *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m') (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Istore with (chunk := chunk) (addr := addr) (args := args) (a := a) (src := src). + exact ALTER. + rewrite eval_addressing_preserved with (ge1 := ge). + { + replace (trs ## args) with (tl (trs ## (instr_uses (Istore chunk addr args src pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + replace (trs # src) with (hd Vundef (trs ## (instr_uses (Istore chunk addr args src pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. + eassumption. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * constructor; trivial. + apply match_regs_trans with (rs2 := trs); trivial. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Istore with (chunk := chunk) (addr := addr) (args := args) (a := a) (src := src). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** rewrite eval_addressing_preserved with (ge1 := ge). + { + replace (trs ## args) with (tl (trs ## (instr_uses (Istore chunk addr args src pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + } + exact symbols_preserved. + ** replace (trs # src) with (hd Vundef (trs ## (instr_uses (Istore chunk addr args src pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. + eassumption. + * constructor; trivial. - admit. - admit. - admit. -- cgit From d05a507e17762e5a0887b868ad2f904c08634c06 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 15:31:48 +0200 Subject: call (could not handle it) --- backend/Injectproof.v | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 62 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index b2ea2562..a895355d 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1115,6 +1115,25 @@ Section INJECTOR. apply MATCH. trivial. Qed. + + Lemma transf_function_preserves_ros: + forall f tf pc rs trs ros args res fd pc' sig + (FUN : transf_function gen_injections f = OK tf) + (MATCH : match_regs f rs trs) + (INSTR : (fn_code f) ! pc = Some (Icall sig ros args res pc')) + (FIND : find_function ge ros rs = Some fd), + exists tfd, find_function tge ros trs = Some tfd + /\ transf_fundef gen_injections fd = OK tfd. + Proof. + intros; destruct ros as [r|id]. + - apply functions_translated; auto. + replace (trs # r) with (hd Vundef (trs ## (instr_uses (Icall sig (inl r) args res pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + - simpl. rewrite symbols_preserved. + simpl in FIND. + destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. + Qed. Theorem transf_step_correct: forall s1 t s2, step ge s1 t s2 -> @@ -1355,7 +1374,49 @@ Section INJECTOR. simpl. eassumption. * constructor; trivial. - - admit. + - (* call *) + destruct (transf_function_preserves_ros f tf pc rs trs ros args res fd pc' (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + simpl in ALTER. + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Icall with (args := args) (sig := (funsig fd)) (ros := ros). + exact ALTER. + exact TFD1. + apply sig_preserved; auto. + * destruct ros as [r | id]. + ** replace (trs ## args) with (tl (trs ## (instr_uses (Icall (funsig fd) (inl r) args res pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + constructor; auto. + constructor; auto. + ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + constructor; auto. + constructor; auto. + + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Icall with (args := args) (sig := (funsig fd)) (ros := ros). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** exact TFD1. + ** apply sig_preserved; auto. + * destruct ros as [r | id]. + ** replace (trs ## args) with (tl (trs ## (instr_uses (Icall (funsig fd) (inl r) args res pc')))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + constructor; auto. + constructor; auto. + ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + constructor; auto. + constructor; auto. + - admit. - admit. - admit. -- cgit From 52864f86e9504896df8ff543c9f352f268ef1ae4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 15:52:35 +0200 Subject: tailcall --- backend/Injectproof.v | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 58 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index a895355d..6513a8d0 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1134,6 +1134,25 @@ Section INJECTOR. destruct (Genv.find_symbol ge id); try congruence. eapply function_ptr_translated; eauto. Qed. + + Lemma transf_function_preserves_ros_tail: + forall f tf pc rs trs ros args fd sig + (FUN : transf_function gen_injections f = OK tf) + (MATCH : match_regs f rs trs) + (INSTR : (fn_code f) ! pc = Some (Itailcall sig ros args)) + (FIND : find_function ge ros rs = Some fd), + exists tfd, find_function tge ros trs = Some tfd + /\ transf_fundef gen_injections fd = OK tfd. + Proof. + intros; destruct ros as [r|id]. + - apply functions_translated; auto. + replace (trs # r) with (hd Vundef (trs ## (instr_uses (Itailcall sig (inl r) args)))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + - simpl. rewrite symbols_preserved. + simpl in FIND. + destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. + Qed. Theorem transf_step_correct: forall s1 t s2, step ge s1 t s2 -> @@ -1417,7 +1436,45 @@ Section INJECTOR. constructor; auto. constructor; auto. - - admit. + - (* tailcall *) + destruct (transf_function_preserves_ros_tail f tf pc rs trs ros args fd (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + simpl in ALTER. + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Itailcall with (args := args) (sig := (funsig fd)) (ros := ros). + exact ALTER. + exact TFD1. + apply sig_preserved; auto. + rewrite stacksize_preserved with (f:=f) by trivial. + eassumption. + * destruct ros as [r | id]. + ** replace (trs ## args) with (tl (trs ## (instr_uses (Itailcall (funsig fd) (inl r) args)))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + ** replace (trs ## args) with (trs ## (instr_uses (Itailcall (funsig fd) (inr id) args))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Itailcall with (args := args) (sig := (funsig fd)) (ros := ros). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** exact TFD1. + ** apply sig_preserved; auto. + ** rewrite stacksize_preserved with (f:=f) by trivial. + eassumption. + * destruct ros as [r | id]. + ** replace (trs ## args) with (tl (trs ## (instr_uses (Itailcall (funsig fd) (inl r) args)))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + ** replace (trs ## args) with (trs ## (instr_uses (Itailcall (funsig fd) (inr id) args))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + apply match_states_call; auto. + - admit. - admit. - admit. -- cgit From ba1c4372b984293ca75a524eb0e532d354377ade Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 16:11:45 +0200 Subject: builtin (incomplete) --- backend/Injectproof.v | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 6513a8d0..306e855b 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1475,6 +1475,39 @@ Section INJECTOR. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. apply match_states_call; auto. + - (* builtin *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m') + (trs := (regmap_setres res vres trs)). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Ibuiltin with (ef := ef) (args := args) (res := res) (vargs := vargs). + *** exact ALTER. + *** apply eval_builtin_args_preserved with (ge1 := ge); eauto. + exact symbols_preserved. + admit. + *** eapply external_call_symbols_preserved; eauto. apply senv_preserved. + ** apply Smallstep.plus_star. + exact PLUS. + ** symmetry. apply E0_right. + * constructor; trivial. + apply match_regs_trans with (rs2 := (regmap_setres res vres trs)); trivial. + admit. + + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Ibuiltin with (ef := ef) (args := args) (res := res) (vargs := vargs). + ** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + ** apply eval_builtin_args_preserved with (ge1 := ge); eauto. + exact symbols_preserved. + admit. + ** eapply external_call_symbols_preserved; eauto. apply senv_preserved. + * admit. + - admit. - admit. - admit. -- cgit From e55776fd96f78518da49dfa9e856c3e070353fc9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 16:25:41 +0200 Subject: cond --- backend/Injectproof.v | 56 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 54 insertions(+), 2 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 306e855b..11472c0e 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1508,8 +1508,60 @@ Section INJECTOR. ** eapply external_call_symbols_preserved; eauto. apply senv_preserved. * admit. - - admit. - - admit. + - (* cond *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + destruct b eqn:B. + ++ exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_left. + ** apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot). + exact ALTER. + replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. reflexivity. + ** apply Smallstep.plus_star. + exact PLUS. + ** reflexivity. + * simpl. constructor; auto. + apply match_regs_trans with (rs2:=trs); auto. + + ++ exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * eapply Smallstep.plus_one. + apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot). + exact ALTER. + replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + simpl. reflexivity. + * simpl. constructor; auto. + + destruct b eqn:B. + * econstructor; split. + ** eapply Smallstep.plus_one. + apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot). + *** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + *** replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + *** reflexivity. + ** constructor; auto. + * econstructor; split. + ** eapply Smallstep.plus_one. + apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot). + *** rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + *** replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + *** reflexivity. + ** constructor; auto. + - admit. - admit. - admit. -- cgit From e52663259c93ee91a74c57df9ff554d799d42320 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 16:40:52 +0200 Subject: jumptable --- backend/Injectproof.v | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 11472c0e..7576fb30 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1562,7 +1562,28 @@ Section INJECTOR. *** reflexivity. ** constructor; auto. - - admit. + - destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := sp) (m := m) (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Ijumptable with (arg := arg) (tbl := tbl) (n := n); trivial. + replace (trs # arg) with (hd Vundef (trs ## (instr_uses (Ijumptable arg tbl)))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + eassumption. + * constructor; trivial. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Ijumptable with (arg := arg) (tbl := tbl) (n := n); trivial. + rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + replace (trs # arg) with (hd Vundef (trs ## (instr_uses (Ijumptable arg tbl)))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + eassumption. + * constructor; trivial. - admit. - admit. - admit. -- cgit From 501d6501b9de645843cfa1e1408ba3fe9318223f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 16:51:36 +0200 Subject: return --- backend/Injectproof.v | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 7576fb30..013bc247 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1584,7 +1584,35 @@ Section INJECTOR. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. eassumption. * constructor; trivial. - - admit. + - (* return *) + destruct ((gen_injections f) ! pc) eqn:INJECTION. + + exploit transf_function_redirects; eauto. + { eapply max_pc_function_sound; eauto. } + intros [pc_inj [ALTER SKIP]]. + specialize SKIP with (ts := ts) (sp := (Vptr stk Ptrofs.zero)) (m := m) (trs := trs). + destruct SKIP as [trs' [MATCH PLUS]]. + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Ireturn. + exact ALTER. + rewrite stacksize_preserved with (f:=f); eassumption. + * destruct or as [r | ]; simpl. + ** replace (trs # r) with (hd Vundef (trs ## (instr_uses (Ireturn (Some r))))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + constructor; auto. + ** constructor; auto. + + econstructor; split. + * apply Smallstep.plus_one. + apply exec_Ireturn. + rewrite transf_function_preserves with (f:=f); eauto. + eapply max_pc_function_sound; eauto. + rewrite stacksize_preserved with (f:=f); eassumption. + * destruct or as [r | ]; simpl. + ** replace (trs # r) with (hd Vundef (trs ## (instr_uses (Ireturn (Some r))))) by reflexivity. + rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. + constructor; auto. + ** constructor; auto. + - admit. - admit. - admit. -- cgit From ee6b5b9e5445f64b26776cf16c2b9cef60b84574 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 17:03:24 +0200 Subject: internal call --- backend/Injectproof.v | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 013bc247..40c39b89 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1613,7 +1613,17 @@ Section INJECTOR. constructor; auto. ** constructor; auto. - - admit. + - (* internal call *) + monadInv FUN. + econstructor; split. + + apply Smallstep.plus_one. + apply exec_function_internal. + rewrite stacksize_preserved with (f:=f) by assumption. + eassumption. + + rewrite entrypoint_preserved with (f:=f)(tf:=x) by assumption. + constructor; auto. + rewrite params_preserved with (f:=f)(tf:=x) by assumption. + apply match_regs_refl. - admit. - admit. Admitted. -- cgit From 7c18e5fbe3dee48b6a7f38d19cbb19427e6722fd Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 17:07:23 +0200 Subject: external call --- backend/Injectproof.v | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 40c39b89..c9493baf 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1624,7 +1624,14 @@ Section INJECTOR. constructor; auto. rewrite params_preserved with (f:=f)(tf:=x) by assumption. apply match_regs_refl. - - admit. + - (* external call *) + monadInv FUN. + econstructor; split. + + apply Smallstep.plus_one. + apply exec_function_external. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor; auto. + - admit. Admitted. -- cgit From cc2d5def041128ae6dcbf46455db3341e74e995c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 17:12:42 +0200 Subject: except for builtins, finished the proof --- backend/Inject.v | 2 +- backend/Injectproof.v | 10 ++++++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/backend/Inject.v b/backend/Inject.v index 57aa343b..1a8ec24a 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -46,9 +46,9 @@ Definition alter_successor (i : instruction) (pc' : node) : instruction := | Iop op args dst _ => Iop op args dst pc' | Iload trap chunk addr args dst _ => Iload trap chunk addr args dst pc' | Istore chunk addr args src _ => Istore chunk addr args src pc' - | Icall sig ri args dst _ => Icall sig ri args dst pc' | Ibuiltin ef args res _ => Ibuiltin ef args res pc' | Icond cond args _ pc2 => Icond cond args pc' pc2 + | Icall _ _ _ _ _ | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => i diff --git a/backend/Injectproof.v b/backend/Injectproof.v index c9493baf..2bfd9701 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -934,7 +934,6 @@ Section INJECTOR. injection VALIDATE. intro TF. symmetry in TF. - Check inject_l_injected_end. pose proof (inject_l_injected_end (PTree.elements (gen_injections f)) (fn_code f) inj_n src_pc i inj_code (Pos.succ (max_pc_function f))) as INJECTED. lapply INJECTED. 2: assumption. @@ -1632,7 +1631,14 @@ Section INJECTOR. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor; auto. - - admit. + - (* return *) + inv STACKS. inv H1. + econstructor; split. + + apply Smallstep.plus_one. + apply exec_return. + + constructor; trivial. + apply match_regs_write. + assumption. Admitted. Theorem transf_program_correct: -- cgit From 031b1525ad7f27fa67f48ae83b101b5c2b969af7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 18:56:17 +0200 Subject: more about builtin args --- backend/Injectproof.v | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 83 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 2bfd9701..93cbdc10 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1094,6 +1094,87 @@ Section INJECTOR. apply SAME. right. assumption. Qed. + (* + Lemma transf_function_preserves_builtin_arg: + forall rs trs ef res sp m pc' + (arg : builtin_arg reg) + (SAME : (forall r, + In r (instr_uses (Ibuiltin ef args res pc')) -> + trs # r = rs # r) ) + varg + (EVAL : eval_builtin_arg ge (fun r => rs#r) sp m arg varg), + eval_builtin_arg ge (fun r => trs#r) sp m arg varg. + Proof. + *) + + Lemma transf_function_preserves_builtin_args_rec: + forall rs trs ef res sp m pc' + (args : list (builtin_arg reg)) + (SAME : (forall r, + In r (instr_uses (Ibuiltin ef args res pc')) -> + trs # r = rs # r) ) + (vargs : list val) + (EVAL : eval_builtin_args ge (fun r => rs#r) sp m args vargs), + eval_builtin_args ge (fun r => trs#r) sp m args vargs. + Proof. + unfold eval_builtin_args. + induction args; intros; inv EVAL. + - constructor. + - constructor. + + induction H1. + all: try (constructor; auto; fail). + * rewrite <- SAME. + apply eval_BA. + simpl. + left. reflexivity. + * constructor. + ** apply IHeval_builtin_arg1. + intros r INr. + apply SAME. + simpl. + simpl in INr. + rewrite in_app in INr. + rewrite in_app. + rewrite in_app. + tauto. + ** apply IHeval_builtin_arg2. + intros r INr. + apply SAME. + simpl. + simpl in INr. + rewrite in_app in INr. + rewrite in_app. + rewrite in_app. + tauto. + * constructor. + ** apply IHeval_builtin_arg1. + intros r INr. + apply SAME. + simpl. + simpl in INr. + rewrite in_app in INr. + rewrite in_app. + rewrite in_app. + tauto. + ** apply IHeval_builtin_arg2. + intros r INr. + apply SAME. + simpl. + simpl in INr. + rewrite in_app in INr. + rewrite in_app. + rewrite in_app. + tauto. + + apply IHargs. + 2: assumption. + intros r INr. + apply SAME. + simpl. + apply in_or_app. + right. + exact INr. + Qed. + Lemma match_regs_write: forall f rs trs res v (MATCH : match_regs f rs trs), @@ -1488,7 +1569,8 @@ Section INJECTOR. *** exact ALTER. *** apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - admit. + Compute (instr_uses (Ibuiltin ef args res pc')). + (instr_uses *** eapply external_call_symbols_preserved; eauto. apply senv_preserved. ** apply Smallstep.plus_star. exact PLUS. -- cgit From e4c053f3ddfb8fbea125ba5100293e013900d0b1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:02:02 +0200 Subject: resolved an "admit" --- backend/Injectproof.v | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 93cbdc10..0a53dc9f 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1174,7 +1174,25 @@ Section INJECTOR. right. exact INr. Qed. - + + Lemma transf_function_preserves_builtin_args: + forall f tf pc rs trs ef res sp m pc' + (args : list (builtin_arg reg)) + (FUN : transf_function gen_injections f = OK tf) + (MATCH : match_regs f rs trs) + (INSTR : (fn_code f) ! pc = Some (Ibuiltin ef args res pc')) + (vargs : list val) + (EVAL : eval_builtin_args ge (fun r => rs#r) sp m args vargs), + eval_builtin_args ge (fun r => trs#r) sp m args vargs. + Proof. + intros. + apply transf_function_preserves_builtin_args_rec with (rs := rs) (ef := ef) (res := res) (pc' := pc'). + intros r INr. + apply MATCH. + apply (max_reg_function_use f pc (Ibuiltin ef args res pc')). + all: auto. + Qed. + Lemma match_regs_write: forall f rs trs res v (MATCH : match_regs f rs trs), @@ -1569,8 +1587,7 @@ Section INJECTOR. *** exact ALTER. *** apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - Compute (instr_uses (Ibuiltin ef args res pc')). - (instr_uses + apply transf_function_preserves_builtin_args with (f:=f) (tf:=tf) (pc:=pc) (rs:=rs) (ef:=ef) (res0:=res) (pc':=pc'); auto. *** eapply external_call_symbols_preserved; eauto. apply senv_preserved. ** apply Smallstep.plus_star. exact PLUS. -- cgit From 3d87236deffbcbfd8d56a9080482071602f9ea01 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:05:03 +0200 Subject: fewer admits --- backend/Injectproof.v | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 0a53dc9f..7ba4b9f7 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1214,6 +1214,15 @@ Section INJECTOR. trivial. Qed. + Lemma match_regs_setres: + forall f res rs trs vres + (MATCH : match_regs f rs trs), + match_regs f (regmap_setres res vres rs) (regmap_setres res vres trs). + Proof. + induction res; simpl; intros; trivial. + apply match_regs_write; auto. + Qed. + Lemma transf_function_preserves_ros: forall f tf pc rs trs ros args res fd pc' sig (FUN : transf_function gen_injections f = OK tf) @@ -1594,7 +1603,8 @@ Section INJECTOR. ** symmetry. apply E0_right. * constructor; trivial. apply match_regs_trans with (rs2 := (regmap_setres res vres trs)); trivial. - admit. + apply match_regs_setres. + assumption. + econstructor; split. * eapply Smallstep.plus_one. apply exec_Ibuiltin with (ef := ef) (args := args) (res := res) (vargs := vargs). -- cgit From 7893d5ece9a06d2ec09eb0a9c1e5207a15668723 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:06:42 +0200 Subject: no more admitted --- backend/Injectproof.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 7ba4b9f7..b63f9498 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1612,9 +1612,11 @@ Section INJECTOR. eapply max_pc_function_sound; eauto. ** apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - admit. + apply transf_function_preserves_builtin_args with (f:=f) (tf:=tf) (pc:=pc) (rs:=rs) (ef:=ef) (res0:=res) (pc':=pc'); auto. ** eapply external_call_symbols_preserved; eauto. apply senv_preserved. - * admit. + * constructor; auto. + apply match_regs_setres. + assumption. - (* cond *) destruct ((gen_injections f) ! pc) eqn:INJECTION. @@ -1748,7 +1750,7 @@ Section INJECTOR. + constructor; trivial. apply match_regs_write. assumption. - Admitted. + Qed. Theorem transf_program_correct: Smallstep.forward_simulation (semantics prog) (semantics tprog). -- cgit From d564ede57b308650da227c254e381c33c7240d08 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 31 Mar 2020 19:15:38 +0200 Subject: no more admitted --- backend/CSE3proof.v | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 1472fbb1..19fb20be 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -830,7 +830,10 @@ Proof. econstructor. split. + eapply exec_return. + econstructor; eauto. -Admitted. + apply wt_regset_assign; trivial. + rewrite WTRES0. + exact WTRES. +Qed. Lemma transf_initial_states: forall S1, RTL.initial_state prog S1 -> -- cgit From 87a4d7e9f493876821e26548d379132f16a7a8ea Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 08:10:08 +0200 Subject: preparatory work for allowing injection after calls --- backend/Injectproof.v | 46 ++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 40 insertions(+), 6 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index b63f9498..dfecbac7 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -572,13 +572,20 @@ Section INJECTOR. specialize M23 with r. intuition congruence. Qed. - + Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := - | match_frames_intro: forall res f tf sp pc rs trs + | match_frames_intro: forall res f tf sp pc pc' rs trs (FUN : transf_function gen_injections f = OK tf) - (REGS : match_regs f rs trs), + (REGS : match_regs f rs trs) + (STAR: + forall ts m trs1, + exists trs2, + (match_regs f trs1 trs2) /\ + Smallstep.star RTL.step tge + (State ts tf sp pc' trs1 m) E0 + (State ts tf sp pc trs2 m)), match_frames (Stackframe res f sp pc rs) - (Stackframe res tf sp pc trs). + (Stackframe res tf sp pc' trs). Inductive match_states: state -> state -> Prop := | match_states_intro: @@ -1519,11 +1526,23 @@ Section INJECTOR. apply match_states_call; auto. constructor; auto. constructor; auto. + + (* FIXME *) + intros. + exists trs1. split. + apply match_regs_refl. + constructor. + ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. apply match_states_call; auto. constructor; auto. constructor; auto. + (* FIXME *) + intros. + exists trs1. split. + apply match_regs_refl. + constructor. + econstructor; split. * eapply Smallstep.plus_one. apply exec_Icall with (args := args) (sig := (funsig fd)) (ros := ros). @@ -1537,11 +1556,21 @@ Section INJECTOR. apply match_states_call; auto. constructor; auto. constructor; auto. + (* FIXME *) + intros. + exists trs1. split. + apply match_regs_refl. + constructor. ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. apply match_states_call; auto. constructor; auto. constructor; auto. + (* FIXME *) + intros. + exists trs1. split. + apply match_regs_refl. + constructor. - (* tailcall *) destruct (transf_function_preserves_ros_tail f tf pc rs trs ros args fd (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. @@ -1744,12 +1773,17 @@ Section INJECTOR. - (* return *) inv STACKS. inv H1. + destruct (STAR bl m (trs # res <- vres)) as [trs2 [MATCH' STAR']]. econstructor; split. - + apply Smallstep.plus_one. - apply exec_return. + + eapply Smallstep.plus_left. + * apply exec_return. + * exact STAR'. + * reflexivity. + constructor; trivial. + apply match_regs_trans with (rs2 := (trs # res <- vres)). apply match_regs_write. assumption. + assumption. Qed. Theorem transf_program_correct: -- cgit From 82c4699c8d5dd12e29b79045b6b8d2daf573ac91 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 08:27:57 +0200 Subject: now able to inject on Call --- backend/Inject.v | 2 +- backend/Injectproof.v | 33 +++++++++++++++------------------ 2 files changed, 16 insertions(+), 19 deletions(-) diff --git a/backend/Inject.v b/backend/Inject.v index 1a8ec24a..4bb25615 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -48,7 +48,7 @@ Definition alter_successor (i : instruction) (pc' : node) : instruction := | Istore chunk addr args src _ => Istore chunk addr args src pc' | Ibuiltin ef args res _ => Ibuiltin ef args res pc' | Icond cond args _ pc2 => Icond cond args pc' pc2 - | Icall _ _ _ _ _ + | Icall sig ros args res _ => Icall sig ros args res pc' | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => i diff --git a/backend/Injectproof.v b/backend/Injectproof.v index dfecbac7..1dd26a24 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1527,22 +1527,22 @@ Section INJECTOR. constructor; auto. constructor; auto. - (* FIXME *) intros. - exists trs1. split. - apply match_regs_refl. - constructor. + destruct (SKIP ts0 sp m0 trs1) as [trs2 [MATCH PLUS]]. + exists trs2. split. assumption. + apply Smallstep.plus_star. exact PLUS. ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. apply match_states_call; auto. constructor; auto. constructor; auto. - (* FIXME *) + intros. - exists trs1. split. - apply match_regs_refl. - constructor. + destruct (SKIP ts0 sp m0 trs1) as [trs2 [MATCH PLUS]]. + exists trs2. split. assumption. + apply Smallstep.plus_star. exact PLUS. + + econstructor; split. * eapply Smallstep.plus_one. apply exec_Icall with (args := args) (sig := (funsig fd)) (ros := ros). @@ -1556,21 +1556,18 @@ Section INJECTOR. apply match_states_call; auto. constructor; auto. constructor; auto. - (* FIXME *) - intros. - exists trs1. split. - apply match_regs_refl. - constructor. + + intros. exists trs1. split. + apply match_regs_refl. constructor. + ** replace (trs ## args) with (trs ## (instr_uses (Icall (funsig fd) (inr id) args res pc'))) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. apply match_states_call; auto. constructor; auto. constructor; auto. - (* FIXME *) - intros. - exists trs1. split. - apply match_regs_refl. - constructor. + + intros. exists trs1. split. + apply match_regs_refl. constructor. - (* tailcall *) destruct (transf_function_preserves_ros_tail f tf pc rs trs ros args fd (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. -- cgit From aedaa5cb1435008d1d872b7d6687bec5843798a0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 09:15:28 +0200 Subject: adapting new stuff for ARM and AArch64 --- aarch64/Op.v | 11 ++++++++--- arm/Op.v | 11 ++++++++--- backend/FirstNopproof.v | 17 ++++++++--------- backend/Injectproof.v | 15 ++++++--------- 4 files changed, 30 insertions(+), 24 deletions(-) diff --git a/aarch64/Op.v b/aarch64/Op.v index c0b9d435..afc25aa6 100644 --- a/aarch64/Op.v +++ b/aarch64/Op.v @@ -938,14 +938,19 @@ Definition is_trapping_op (op : operation) := end. +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). diff --git a/arm/Op.v b/arm/Op.v index 671bdbe4..25e48ce1 100644 --- a/arm/Op.v +++ b/arm/Op.v @@ -531,14 +531,19 @@ Definition is_trapping_op (op : operation) := end. +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). diff --git a/backend/FirstNopproof.v b/backend/FirstNopproof.v index 5d9a7d6a..a5d63c25 100644 --- a/backend/FirstNopproof.v +++ b/backend/FirstNopproof.v @@ -168,26 +168,25 @@ Proof. + constructor; auto with firstnop. - left. econstructor. split. + eapply plus_one. eapply exec_Iload with (v:=v); eauto with firstnop. - rewrite <- H0. - apply eval_addressing_preserved. - apply symbols_preserved. + all: rewrite <- H0. + all: auto using eval_addressing_preserved, symbols_preserved. + constructor; auto with firstnop. - left. econstructor. split. + eapply plus_one. eapply exec_Iload_notrap1; eauto with firstnop. - rewrite <- H0. - apply eval_addressing_preserved. + all: rewrite <- H0; + apply eval_addressing_preserved; apply symbols_preserved. + constructor; auto with firstnop. - left. econstructor. split. + eapply plus_one. eapply exec_Iload_notrap2; eauto with firstnop. - rewrite <- H0. - apply eval_addressing_preserved. + all: rewrite <- H0; + apply eval_addressing_preserved; apply symbols_preserved. + constructor; auto with firstnop. - left. econstructor. split. + eapply plus_one. eapply exec_Istore; eauto with firstnop. - rewrite <- H0. - apply eval_addressing_preserved. + all: rewrite <- H0; + apply eval_addressing_preserved; apply symbols_preserved. + constructor; auto with firstnop. - left. econstructor. split. diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 1dd26a24..77cae8a1 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -778,23 +778,20 @@ Section INJECTOR. * exists (trs # res <- v). split. ** apply exec_Iload with (trap := NOTRAP) (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); trivial. - rewrite eval_addressing_preserved with (ge1 := ge). - assumption. - exact symbols_preserved. + all: try rewrite eval_addressing_preserved with (ge1 := ge). + all: auto using symbols_preserved. ** apply assign_above; auto. * exists (trs # res <- Vundef). split. ** apply exec_Iload_notrap2 with (chunk := chunk) (addr := addr) (args := args) (dst := res) (a := a); trivial. - rewrite eval_addressing_preserved with (ge1 := ge). - assumption. - exact symbols_preserved. + all: rewrite eval_addressing_preserved with (ge1 := ge). + all: auto using symbols_preserved. ** apply assign_above; auto. + exists (trs # res <- Vundef). split. * apply exec_Iload_notrap1 with (chunk := chunk) (addr := addr) (args := args) (dst := res); trivial. - rewrite eval_addressing_preserved with (ge1 := ge). - assumption. - exact symbols_preserved. + all: rewrite eval_addressing_preserved with (ge1 := ge). + all: auto using symbols_preserved. * apply assign_above; auto. Qed. -- cgit From 8e3ae6d6ff625dc8f93c54392b80b836b613c3cc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 09:30:18 +0200 Subject: porting to ppc riscV x86 --- powerpc/Op.v | 12 +++++++++--- riscV/Op.v | 12 +++++++++--- x86/Op.v | 11 ++++++++--- 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/powerpc/Op.v b/powerpc/Op.v index b73cb14b..a0ee5bb8 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -592,14 +592,20 @@ Definition is_trapping_op (op : operation) := | _ => false end. +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + + Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). diff --git a/riscV/Op.v b/riscV/Op.v index a71696c7..14d07e0b 100644 --- a/riscV/Op.v +++ b/riscV/Op.v @@ -682,15 +682,21 @@ Definition is_trapping_op (op : operation) := | Ofloatoflong | Ofloatoflongu => true | _ => false end. + + +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). diff --git a/x86/Op.v b/x86/Op.v index 15672bbe..28e6dbd8 100644 --- a/x86/Op.v +++ b/x86/Op.v @@ -760,14 +760,19 @@ Definition is_trapping_op (op : operation) := | _ => false end. +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + Lemma is_trapping_op_sound: forall op vl sp m, - op <> Omove -> is_trapping_op op = false -> - (List.length vl) = (List.length (fst (type_of_operation op))) -> + (List.length vl) = args_of_operation op -> eval_operation genv sp op vl m <> None. Proof. - destruct op; intros; simpl in *; try congruence. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. all: try (destruct vl as [ | vh1 vl1]; try discriminate). all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). -- cgit From d0590cab5ee32df395c129ee3edfa2dc3aaa202d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 13:30:30 +0200 Subject: begin adapting for LICM phase --- backend/Inject.v | 4 ++-- backend/Injectproof.v | 60 ++++++++++++++++++++++++------------------------- driver/Clflags.ml | 1 + driver/Compopts.v | 3 +++ driver/Driver.ml | 2 ++ extraction/extraction.v | 3 +++ 6 files changed, 41 insertions(+), 32 deletions(-) diff --git a/backend/Inject.v b/backend/Inject.v index 4bb25615..2350c149 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -81,7 +81,7 @@ Definition inject prog extra_pc injections : code := *) Section INJECTOR. - Variable gen_injections : function -> PTree.t (list inj_instr). + Variable gen_injections : function -> node -> reg -> PTree.t (list inj_instr). Definition valid_injection_instr (max_reg : reg) (i : inj_instr) := match i with @@ -102,9 +102,9 @@ Section INJECTOR. valid_injections1 (max_pc_function f) (max_reg_function f). Definition transf_function (f : function) : res function := - let injections := PTree.elements (gen_injections f) in let max_pc := max_pc_function f in let max_reg := max_reg_function f in + let injections := PTree.elements (gen_injections f max_pc max_reg) in if valid_injections1 max_pc max_reg injections then OK {| fn_sig := f.(fn_sig); diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 77cae8a1..2506bcc8 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -538,7 +538,7 @@ Qed. *) Section INJECTOR. - Variable gen_injections : function -> PTree.t (list inj_instr). + Variable gen_injections : function -> node -> reg -> PTree.t (list inj_instr). Definition match_prog (p tp: RTL.program) := match_program (fun ctx f tf => transf_fundef gen_injections f = OK tf) eq p tp. @@ -808,10 +808,10 @@ Section INJECTOR. Lemma transf_function_inj_starstep_rec : forall ts f tf sp m inj_n src_pc inj_pc inj_code (FUN : transf_function gen_injections f = OK tf) - (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + (INJ : nth_error (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = Some (src_pc, inj_code)) (POSITION : inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) inj_n = inj_pc) + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = inj_pc) (k : nat) (CUR : (k <= (List.length inj_code))%nat) (trs : regset), @@ -839,7 +839,7 @@ Section INJECTOR. injection VALIDATE. intro TF. symmetry in TF. - pose proof (inject_l_injected (PTree.elements (gen_injections f)) (fn_code f) inj_n src_pc inj_code (Pos.succ (max_pc_function f)) ((List.length inj_code) - (S k))%nat) as INJECTED. + pose proof (inject_l_injected (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) (fn_code f) inj_n src_pc inj_code (Pos.succ (max_pc_function f)) ((List.length inj_code) - (S k))%nat) as INJECTED. lapply INJECTED. { clear INJECTED. intro INJECTED. @@ -848,7 +848,7 @@ Section INJECTOR. pose proof (INJECTED INJ LESS) as INJ'. replace (snd (inject_l (fn_code f) (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)))) with (fn_code tf) in INJ'. + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))))) with (fn_code tf) in INJ'. 2: rewrite TF; simpl; reflexivity. apply transf_function_inj_step with (f:=f) (ts:=ts) (sp:=sp) (trs:=trs) (m := m) in INJ'. 2: assumption. { @@ -898,10 +898,10 @@ Section INJECTOR. Lemma transf_function_inj_starstep : forall ts f tf sp m inj_n src_pc inj_pc inj_code (FUN : transf_function gen_injections f = OK tf) - (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + (INJ : nth_error (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = Some (src_pc, inj_code)) (POSITION : inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) inj_n = inj_pc) + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = inj_pc) (trs : regset), exists trs', match_regs (f : function) trs trs' /\ @@ -920,11 +920,11 @@ Section INJECTOR. Lemma transf_function_inj_end : forall ts f tf sp m inj_n src_pc inj_pc inj_code i (FUN : transf_function gen_injections f = OK tf) - (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + (INJ : nth_error (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = Some (src_pc, inj_code)) (SRC: (fn_code f) ! src_pc = Some i) (POSITION : inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) inj_n = inj_pc) + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = inj_pc) (trs : regset), RTL.step tge (State ts tf sp (pos_add_nat inj_pc (List.length inj_code)) trs m) E0 @@ -938,13 +938,13 @@ Section INJECTOR. injection VALIDATE. intro TF. symmetry in TF. - pose proof (inject_l_injected_end (PTree.elements (gen_injections f)) (fn_code f) inj_n src_pc i inj_code (Pos.succ (max_pc_function f))) as INJECTED. + pose proof (inject_l_injected_end (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) (fn_code f) inj_n src_pc i inj_code (Pos.succ (max_pc_function f))) as INJECTED. lapply INJECTED. 2: assumption. clear INJECTED. intro INJECTED. lapply INJECTED. - 2: apply (PTree.elements_keys_norepet (gen_injections f)); fail. + 2: apply (PTree.elements_keys_norepet (gen_injections f (max_pc_function f) (max_reg_function f))); fail. clear INJECTED. intro INJECTED. lapply INJECTED. @@ -954,7 +954,7 @@ Section INJECTOR. clear INJECTED. replace (snd (inject_l (fn_code f) (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)))) with (fn_code tf) in INJ'. + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))))) with (fn_code tf) in INJ'. 2: rewrite TF; simpl; reflexivity. rewrite POSITION in INJ'. apply exec_Inop. @@ -975,11 +975,11 @@ Section INJECTOR. Lemma transf_function_inj_plusstep : forall ts f tf sp m inj_n src_pc inj_pc inj_code i (FUN : transf_function gen_injections f = OK tf) - (INJ : nth_error (PTree.elements (gen_injections f)) inj_n = + (INJ : nth_error (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = Some (src_pc, inj_code)) (SRC: (fn_code f) ! src_pc = Some i) (POSITION : inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) inj_n = inj_pc) + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) inj_n = inj_pc) (trs : regset), exists trs', match_regs (f : function) trs trs' /\ @@ -1001,7 +1001,7 @@ Section INJECTOR. forall f tf pc (FUN : transf_function gen_injections f = OK tf) (LESS : pc <= max_pc_function f) - (NOCHANGE : (gen_injections f) ! pc = None), + (NOCHANGE : (gen_injections f (max_pc_function f) (max_reg_function f)) ! pc = None), (fn_code tf) ! pc = (fn_code f) ! pc. Proof. intros. @@ -1027,7 +1027,7 @@ Section INJECTOR. forall f tf pc injl ii (FUN : transf_function gen_injections f = OK tf) (LESS : pc <= max_pc_function f) - (INJECTION : (gen_injections f) ! pc = Some injl) + (INJECTION : (gen_injections f (max_pc_function f) (max_reg_function f)) ! pc = Some injl) (INSTR: (fn_code f) ! pc = Some ii), exists pc' : node, (fn_code tf) ! pc = Some (alter_successor ii pc') /\ @@ -1043,7 +1043,7 @@ Section INJECTOR. apply In_nth_error in INJECTION. destruct INJECTION as [injn INJECTION]. exists (inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) injn). + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) injn). split. { unfold transf_function in FUN. destruct (valid_injections1) eqn:VALID in FUN. @@ -1067,7 +1067,7 @@ Section INJECTOR. intros. pose proof (transf_function_inj_plusstep ts f tf sp m injn pc (inject_l_position (Pos.succ (max_pc_function f)) - (PTree.elements (gen_injections f)) injn) + (PTree.elements (gen_injections f (max_pc_function f) (max_reg_function f))) injn) injl ii FUN INJECTION INSTR) as TRANS. lapply TRANS. 2: reflexivity. @@ -1272,7 +1272,7 @@ Section INJECTOR. Proof. induction 1; intros ts1 MS; inv MS; try (inv TRC). - (* nop *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1295,7 +1295,7 @@ Section INJECTOR. * constructor; trivial. - (* op *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1339,7 +1339,7 @@ Section INJECTOR. assumption. - (* load *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1381,7 +1381,7 @@ Section INJECTOR. assumption. - (* load notrap1 *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1421,7 +1421,7 @@ Section INJECTOR. assumption. - (* load notrap2 *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1463,7 +1463,7 @@ Section INJECTOR. assumption. - (* store *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1506,7 +1506,7 @@ Section INJECTOR. * constructor; trivial. - (* call *) destruct (transf_function_preserves_ros f tf pc rs trs ros args res fd pc' (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1568,7 +1568,7 @@ Section INJECTOR. - (* tailcall *) destruct (transf_function_preserves_ros_tail f tf pc rs trs ros args fd (funsig fd) FUN REGS H H0) as [tfd [TFD1 TFD2]]. - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1606,7 +1606,7 @@ Section INJECTOR. apply match_states_call; auto. - (* builtin *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1642,7 +1642,7 @@ Section INJECTOR. assumption. - (* cond *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + destruct b eqn:B. ++ exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } @@ -1695,7 +1695,7 @@ Section INJECTOR. *** reflexivity. ** constructor; auto. - - destruct ((gen_injections f) ! pc) eqn:INJECTION. + - destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. @@ -1718,7 +1718,7 @@ Section INJECTOR. eassumption. * constructor; trivial. - (* return *) - destruct ((gen_injections f) ! pc) eqn:INJECTION. + destruct ((gen_injections f (max_pc_function f) (max_reg_function f)) ! pc) eqn:INJECTION. + exploit transf_function_redirects; eauto. { eapply max_pc_function_sound; eauto. } intros [pc_inj [ALTER SKIP]]. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index ff2647a7..ae96e820 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -82,5 +82,6 @@ let option_fxsaddr = ref true let option_faddx = ref false let option_fcoalesce_mem = ref true let option_fforward_moves = ref true +let option_fmove_loop_invariants = ref false let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 diff --git a/driver/Compopts.v b/driver/Compopts.v index a3181da8..e4dae87d 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -48,6 +48,9 @@ Parameter optim_CSE3: unit -> bool. (** Flag -fcse3-alias-analysis. For DMonniaux's common subexpression elimination. *) Parameter optim_CSE3_alias_analysis: unit -> bool. +(** Flag -fmove-loop-invariants. *) +Parameter optim_move_loop_invariants: unit -> bool. + (** Flag -fredundancy. For dead code elimination. *) Parameter optim_redundancy: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index b167dbd1..0f9e637c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -199,6 +199,7 @@ Processing options: -fcse2 Perform inter-loop common subexpression elimination [off] -fcse3 Perform inter-loop common subexpression elimination [on] -fcse3-alias-analysis Perform inter-loop common subexpression elimination with alias analysis [on] + -fmove-loop-invariants Perform loop-invariant code motion [off] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] -fpostpass= Perform postpass scheduling with the specified optimization [list] @@ -401,6 +402,7 @@ let cmdline_actions = @ f_opt "cse2" option_fcse2 @ f_opt "cse3" option_fcse3 @ f_opt "cse3-alias-analysis" option_fcse3_alias_analysis + @ f_opt "move-loop-invariants" option_fmove_loop_invariants @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass @ [ Exact "-fduplicate", Integer (fun n -> option_fduplicate := n) ] diff --git a/extraction/extraction.v b/extraction/extraction.v index cb461361..1bb5a709 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -120,6 +120,9 @@ Extract Constant Compopts.optim_CSE3 => "fun _ -> !Clflags.option_fcse3". Extract Constant Compopts.optim_CSE3_alias_analysis => "fun _ -> !Clflags.option_fcse3_alias_analysis". +Extract Constant Compopts.optim_move_loop_invariants => + "fun _ -> !Clflags.option_fmove_loop_invariants". + Extract Constant Compopts.optim_redundancy => "fun _ -> !Clflags.option_fredundancy". Extract Constant Compopts.optim_postpass => -- cgit From 6379f6291eea909426f074db67837b04a1dec9ae Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 14:24:05 +0200 Subject: attempt at compiling --- Makefile | 1 + backend/LICM.v | 9 +++++++++ backend/LICMproof.v | 21 +++++++++++++++++++++ driver/Compiler.v | 36 ++++++++++++++++++++++++------------ 4 files changed, 55 insertions(+), 12 deletions(-) create mode 100644 backend/LICM.v create mode 100644 backend/LICMproof.v diff --git a/Makefile b/Makefile index f005d048..b7fed0d4 100644 --- a/Makefile +++ b/Makefile @@ -91,6 +91,7 @@ BACKEND=\ CSE2deps.v CSE2depsproof.v \ CSE2.v CSE2proof.v \ CSE3analysis.v CSE3analysisproof.v CSE3.v CSE3proof.v \ + LICM.v LICMproof.v \ NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \ Unusedglob.v Unusedglobproof.v \ Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \ diff --git a/backend/LICM.v b/backend/LICM.v new file mode 100644 index 00000000..1b5334ba --- /dev/null +++ b/backend/LICM.v @@ -0,0 +1,9 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. +Require Inject. + +Definition gen_injections (f : function) (max_pc : node) (max_reg : reg): + PTree.t (list Inject.inj_instr) := PTree.empty (list Inject.inj_instr). + +Definition transf_program := Inject.transf_program gen_injections. diff --git a/backend/LICMproof.v b/backend/LICMproof.v new file mode 100644 index 00000000..065a7f74 --- /dev/null +++ b/backend/LICMproof.v @@ -0,0 +1,21 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. +Require Import LICM. +Require Injectproof. + +Definition match_prog : program -> program -> Prop := + Injectproof.match_prog gen_injections. + +Section PRESERVATION. + + Variables prog tprog: program. + Hypothesis TRANSF: match_prog prog tprog. + + Theorem transf_program_correct : + Smallstep.forward_simulation (semantics prog) (semantics tprog). + Proof. + apply Injectproof.transf_program_correct with (gen_injections := gen_injections). + exact TRANSF. + Qed. +End PRESERVATION. diff --git a/driver/Compiler.v b/driver/Compiler.v index 5175abdb..dbf62368 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -41,6 +41,7 @@ Require FirstNop. Require Renumber. Require Duplicate. Require Constprop. +Require LICM. Require CSE. Require ForwardMoves. Require CSE2. @@ -68,6 +69,7 @@ Require FirstNopproof. Require Renumberproof. Require Duplicateproof. Require Constpropproof. +Require LICMproof. Require CSEproof. Require ForwardMovesproof. Require CSE2proof. @@ -136,7 +138,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 1) @@@ time "Inlining" Inlining.transf_program @@ print (print_RTL 2) - @@ time "Inserting initial nop" FirstNop.transf_program + @@ total_if Compopts.optim_move_loop_invariants (time "Inserting initial nop" FirstNop.transf_program) @@ print (print_RTL 3) @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 4) @@ -144,22 +146,26 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 5) @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 6) - @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) + @@ time "Renumbering pre LICM" Renumber.transf_program @@ print (print_RTL 7) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) + @@@ partial_if Compopts.optim_move_loop_invariants (time "LICM" LICM.transf_program) @@ print (print_RTL 8) - @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) + @@ total_if Compopts.optim_move_loop_invariants (time "Renumbering pre CSE" Renumber.transf_program) @@ print (print_RTL 9) - @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) + @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 10) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program + @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 11) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) @@ print (print_RTL 12) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 13) - @@@ time "Unused globals" Unusedglob.transform_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 14) + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@ print (print_RTL 15) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 16) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -261,10 +267,11 @@ Definition CompCert's_passes := ::: mkpass RTLgenproof.match_prog ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog - ::: mkpass FirstNopproof.match_prog + ::: mkpass (match_if Compopts.optim_move_loop_invariants FirstNopproof.match_prog) ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) @@ -308,14 +315,19 @@ Proof. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + ::: mkpass (match_if Compopts.optim_move_loop_invariants LICM.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. - set (p9 := FirstNop.transf_program p8) in *. + set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8) in *. set (p9bis := Renumber.transf_program p9) in *. destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. - destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. + set (p12ter :=(total_if optim_move_loop_invariant Renumber.transf_program p12bis)) in *. + destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. -- cgit From a3d40b88608b8b5e7e615346ea1c33198355cbbc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 14:45:25 +0200 Subject: clearer types --- backend/LICM.v | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/backend/LICM.v b/backend/LICM.v index 1b5334ba..d45eef43 100644 --- a/backend/LICM.v +++ b/backend/LICM.v @@ -6,4 +6,7 @@ Require Inject. Definition gen_injections (f : function) (max_pc : node) (max_reg : reg): PTree.t (list Inject.inj_instr) := PTree.empty (list Inject.inj_instr). -Definition transf_program := Inject.transf_program gen_injections. +Opaque gen_injections. + +Definition transf_program : program -> res program := + Inject.transf_program gen_injections. -- cgit From 01f42ef55d91bbb57b47ecc2be7e691165778980 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 15:38:06 +0200 Subject: fix Compiler.v --- backend/LICMproof.v | 6 ++++++ driver/Compiler.v | 28 ++++++++++++++++------------ 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/backend/LICMproof.v b/backend/LICMproof.v index 065a7f74..2b76b668 100644 --- a/backend/LICMproof.v +++ b/backend/LICMproof.v @@ -12,6 +12,12 @@ Section PRESERVATION. Variables prog tprog: program. Hypothesis TRANSF: match_prog prog tprog. + Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. + Proof. + intros. eapply match_transform_partial_program_contextual; eauto. + Qed. + Theorem transf_program_correct : Smallstep.forward_simulation (semantics prog) (semantics tprog). Proof. diff --git a/driver/Compiler.v b/driver/Compiler.v index dbf62368..89a15d93 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -271,8 +271,9 @@ Definition CompCert's_passes := ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) + ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) - ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) ::: mkpass (match_if Compopts.optim_CSE3 CSE3proof.match_prog) @@ -315,18 +316,15 @@ Proof. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - ::: mkpass (match_if Compopts.optim_move_loop_invariants LICM.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8) in *. set (p9bis := Renumber.transf_program p9) in *. destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. - set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. + set (p12 := Renumber.transf_program p11) in *. destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. - set (p12ter :=(total_if optim_move_loop_invariant Renumber.transf_program p12bis)) in *. + set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. @@ -349,11 +347,13 @@ Proof. exists p6; split. apply RTLgenproof.transf_program_match; auto. exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. exists p8; split. apply Inliningproof.transf_program_match; auto. - exists p9; split. apply FirstNopproof.transf_program_match; auto. - exists p9bis; split. apply Renumberproof.transf_program_match; auto. + exists p9; split. apply total_if_match. apply FirstNopproof.transf_program_match. + exists p9bis; split. apply Renumberproof.transf_program_match. exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p12; split. apply total_if_match. apply Renumberproof.transf_program_match. + exists p12; split. apply Renumberproof.transf_program_match. + exists p12bis; split. eapply partial_if_match; eauto. apply LICMproof.transf_program_match. + exists p12ter; split. apply total_if_match; eauto. apply Renumberproof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. exists p13ter; split. eapply partial_if_match; eauto. apply CSE3proof.transf_program_match. @@ -418,7 +418,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p27)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p29)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -436,12 +436,16 @@ Ltac DestructM := eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. eapply compose_forward_simulations. eapply Inliningproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. eapply FirstNopproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact FirstNopproof.transf_program_correct. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. + eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. + eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact LICMproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct. eapply compose_forward_simulations. -- cgit From 87d2c34910a017c13a908cfe2cf2c627e56e6cfe Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 15:46:03 +0200 Subject: reordering passes --- driver/Compiler.v | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index 89a15d93..e6d39152 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -144,9 +144,9 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 4) @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) @@ print (print_RTL 5) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) + @@ time "Renumbering pre constprop" Renumber.transf_program @@ print (print_RTL 6) - @@ time "Renumbering pre LICM" Renumber.transf_program + @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 7) @@@ partial_if Compopts.optim_move_loop_invariants (time "LICM" LICM.transf_program) @@ print (print_RTL 8) @@ -270,8 +270,8 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_move_loop_invariants FirstNopproof.match_prog) ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) - ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) ::: mkpass Renumberproof.match_prog + ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) @@ -321,8 +321,8 @@ Proof. set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8) in *. set (p9bis := Renumber.transf_program p9) in *. destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. - set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. - set (p12 := Renumber.transf_program p11) in *. + set (p11 := Renumber.transf_program p10) in *. + set (p12 := total_if optim_constprop Constprop.transf_program p11) in *. destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. @@ -350,8 +350,8 @@ Proof. exists p9; split. apply total_if_match. apply FirstNopproof.transf_program_match. exists p9bis; split. apply Renumberproof.transf_program_match. exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. - exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p12; split. apply Renumberproof.transf_program_match. + exists p11; split. apply Renumberproof.transf_program_match. + exists p12; split. apply total_if_match. apply Constpropproof.transf_program_match. exists p12bis; split. eapply partial_if_match; eauto. apply LICMproof.transf_program_match. exists p12ter; split. apply total_if_match; eauto. apply Renumberproof.transf_program_match. exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. @@ -442,8 +442,8 @@ Ltac DestructM := eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact LICMproof.transf_program_correct; eassumption. eapply compose_forward_simulations. -- cgit From aebbc43842ec0c49058b718c685e08edf11ce614 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 16:15:54 +0200 Subject: route through LICMaux --- backend/LICM.v | 5 +---- backend/LICMaux.ml | 4 ++++ extraction/extraction.v | 3 +++ 3 files changed, 8 insertions(+), 4 deletions(-) create mode 100644 backend/LICMaux.ml diff --git a/backend/LICM.v b/backend/LICM.v index d45eef43..0a0a1c7d 100644 --- a/backend/LICM.v +++ b/backend/LICM.v @@ -3,10 +3,7 @@ Require Import AST Linking. Require Import Memory Registers Op RTL. Require Inject. -Definition gen_injections (f : function) (max_pc : node) (max_reg : reg): - PTree.t (list Inject.inj_instr) := PTree.empty (list Inject.inj_instr). - -Opaque gen_injections. +Axiom gen_injections : function -> node -> reg -> PTree.t (list Inject.inj_instr). Definition transf_program : program -> res program := Inject.transf_program gen_injections. diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml new file mode 100644 index 00000000..542b6ea8 --- /dev/null +++ b/backend/LICMaux.ml @@ -0,0 +1,4 @@ +open RTL;; + +let gen_injections (f : function) (max_pc : node) (max_reg : reg) = + PTree.empty;; diff --git a/extraction/extraction.v b/extraction/extraction.v index 1bb5a709..b102503b 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -87,6 +87,9 @@ Extract Inlined Constant Inlining.inlining_info => "Inliningaux.inlining_info". Extract Inlined Constant Inlining.inlining_analysis => "Inliningaux.inlining_analysis". Extraction Inline Inlining.ret Inlining.bind. +(* Loop invariant code motion *) +Extract Inlined Constant LICM.gen_injections => "LICMaux.gen_injections". + (* Allocation *) Extract Constant Allocation.regalloc => "Regalloc.regalloc". -- cgit From 34bb4b19299e21e87871c7159567ac425c70e6b4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 1 Apr 2020 17:18:50 +0200 Subject: toy example for injecting code --- backend/LICMaux.ml | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 542b6ea8..3f7d61b1 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -1,4 +1,31 @@ open RTL;; +open Camlcoq;; +open Maps;; +open Integers;; -let gen_injections (f : function) (max_pc : node) (max_reg : reg) = - PTree.empty;; +type reg = P.t;; + +module IntSet = Set.Make(struct type t=int let compare = (-) end);; + +let loop_headers (f : coq_function) = + PTree.fold (fun (already : IntSet.t) + (coq_pc : node) (instr : instruction) -> + let pc = P.to_int coq_pc in + List.fold_left (fun (already : IntSet.t) (coq_pc' : node) -> + let pc' = P.to_int coq_pc' in + if pc' >= pc + then IntSet.add pc' already + else already) already (successors_instr instr)) + f.fn_code IntSet.empty;; + +let print_loop_headers f = + print_endline "Loop headers"; + IntSet.iter + (fun i -> Printf.printf "%d " i) + (loop_headers f); + print_newline ();; + +let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): + (Inject.inj_instr list) PTree.t = + let max_reg = P.to_int coq_max_reg in + PTree.set coq_max_pc [Inject.INJload(AST.Mint32, (Op.Aindexed (Ptrofs.of_int (Z.of_sint 0))), [P.of_int 1], P.of_int (max_reg+1))] PTree.empty;; -- cgit From 1a70cffa6080d0d9f90bfa7541e46737c9588212 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 2 Apr 2020 16:23:10 +0200 Subject: Fixing loop heuristic --- backend/Duplicateaux.ml | 49 ++++++++++++++++++++++++++++++++++--------------- 1 file changed, 34 insertions(+), 15 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 28ad4266..1f4a693d 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -105,6 +105,7 @@ let get_loop_headers code entrypoint = begin match (get_some @@ PTree.get node !visited) with | Visited -> () | Processed -> begin + Printf.printf "Node %d is a loop header\n" (P.to_int node); is_loop_header := PTree.set node true !is_loop_header; visited := PTree.set node Visited !visited end @@ -238,19 +239,36 @@ let get_loop_info is_loop_header bfs_order code = | Icond (_,_,s1,s2,_) -> (explore s1 dest) || (explore s2 dest) | Ijumptable _ | Itailcall _ | Ireturn _ -> false end - in match get_some @@ PTree.get s !loop_info with - | None -> begin - match get_some @@ PTree.get s code with - | Icond (_, _, n1, n2, _) -> - let b1 = explore n1 n in - let b2 = explore n2 n in - if (b1 && b2) then () - else if b1 then loop_info := PTree.set s (Some true) !loop_info - else if b2 then loop_info := PTree.set s (Some false) !loop_info - else () - | _ -> () + in let rec advance_to_cb src = + if (get_some @@ PTree.get src !visited) then None + else begin + visited := PTree.set src true !visited; + match get_some @@ PTree.get src code with + | Inop s | Iop (_, _, _, s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) + | Ibuiltin (_,_,_,s) -> advance_to_cb s + | Icond _ -> Some src + | Ijumptable _ | Itailcall _ | Ireturn _ -> None end - | Some _ -> () + in begin + Printf.printf "Marking path from %d to %d\n" (P.to_int n) (P.to_int s); + match advance_to_cb s with + | None -> (Printf.printf "Nothing found\n") + | Some s -> ( Printf.printf "Advancing to %d\n" (P.to_int s); + match get_some @@ PTree.get s !loop_info with + | None | Some _ -> begin + match get_some @@ PTree.get s code with + | Icond (_, _, n1, n2, _) -> + let b1 = explore n1 n in + let b2 = explore n2 n in + if (b1 && b2) then (Printf.printf "both true\n") + else if b1 then (Printf.printf "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info) + else if b2 then (Printf.printf "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info) + else (Printf.printf "none true\n") + | _ -> ( Printf.printf "not an icond\n" ) + end + (* | Some _ -> ( Printf.printf "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *) + ) + end in begin List.iter (fun n -> match get_some @@ PTree.get n code with @@ -527,7 +545,7 @@ let rec change_pointers code n n' = function * n': the integer which should contain the duplicate of n * returns: new code, new ptree *) let duplicate code ptree parent n preds n' = - (* Printf.printf "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n'); *) + Printf.printf "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n'); match PTree.get n' code with | Some _ -> failwith "The PTree already has a node n'" | None -> @@ -591,8 +609,9 @@ let superblockify_traces code preds traces = | [] -> (code, ptree, 0) | trace :: traces -> let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace - in if (nb_duplicated < max_nb_duplicated) then f new_code new_ptree traces - else (Printf.printf "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) + in if (nb_duplicated < max_nb_duplicated) + then (Printf.printf "End duplication\n"; f new_code new_ptree traces) + else (Printf.printf "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) in let new_code, new_ptree, _ = f code ptree traces in (new_code, new_ptree) -- cgit From c6356cdc5f567a317afcb99cb004354cf7dcce0f Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Fri, 3 Apr 2020 11:11:19 +0200 Subject: Changing best_predecessor_of to not take None predictions --- backend/Duplicateaux.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 1f4a693d..98e2f325 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -413,11 +413,22 @@ let best_successor_of node code is_visited = | Some n -> if not (ptree_get_some n is_visited) then Some n else None (* FIXME - could be improved by selecting in priority the predicted paths *) -let best_predecessor_of node predecessors order is_visited = +let best_predecessor_of node predecessors code order is_visited = match (PTree.get node predecessors) with | None -> failwith "No predecessor list found" - | Some lp -> try Some (List.find (fun n -> (List.mem n lp) && (not (ptree_get_some n is_visited))) order) - with Not_found -> None + | Some lp -> + try Some (List.find (fun n -> + if (List.mem n lp) && (not (ptree_get_some n is_visited)) then + match ptree_get_some n code with + | Icond (_, _, n1, n2, ob) -> (match ob with + | None -> false + | Some false -> n == n2 + | Some true -> n == n1 + ) + | _ -> true + else false + ) order) + with Not_found -> None let print_trace t = print_intlist t @@ -489,7 +500,7 @@ let select_traces_chang code entrypoint = begin current := seed; quit_loop := false; while not !quit_loop do - let s = best_predecessor_of !current predecessors order !is_visited in + let s = best_predecessor_of !current predecessors code order !is_visited in match s with | None -> quit_loop := true (* if (s==0) exit loop *) | Some pred -> begin -- cgit From 249482aed76d209ff203f9afeeb3f10db004e8c0 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 Apr 2020 21:34:14 +0200 Subject: start implementing expect as expr --- backend/Cminor.v | 2 ++ backend/Cminortyping.v | 1 + backend/PrintCminor.ml | 2 ++ backend/Selection.v | 3 +- backend/Selectionaux.ml | 1 + backend/Selectionproof.v | 85 +++++++++++++++++++++++----------------------- cfrontend/Cminorgenproof.v | 1 + 7 files changed, 52 insertions(+), 43 deletions(-) diff --git a/backend/Cminor.v b/backend/Cminor.v index 91a4c104..dcebbb86 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -77,6 +77,7 @@ Inductive unary_operation : Type := | Osingleoflongu: unary_operation. (**r unsigned long to float32 *) Inductive binary_operation : Type := + | Oexpect: typ -> binary_operation (**r first value, second is expected*) | Oadd: binary_operation (**r integer addition *) | Osub: binary_operation (**r integer subtraction *) | Omul: binary_operation (**r integer multiplication *) @@ -301,6 +302,7 @@ Definition eval_unop (op: unary_operation) (arg: val) : option val := Definition eval_binop (op: binary_operation) (arg1 arg2: val) (m: mem): option val := match op with + | Oexpect ty => Some (Val.normalize arg1 ty) | Oadd => Some (Val.add arg1 arg2) | Osub => Some (Val.sub arg1 arg2) | Omul => Some (Val.mul arg1 arg2) diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v index 92ec45f2..8945cecf 100644 --- a/backend/Cminortyping.v +++ b/backend/Cminortyping.v @@ -64,6 +64,7 @@ Definition type_binop (op: binary_operation) : typ * typ * typ := | Ocmpf _ => (Tfloat, Tfloat, Tint) | Ocmpfs _ => (Tsingle, Tsingle, Tint) | Ocmpl _ | Ocmplu _ => (Tlong, Tlong, Tint) + | Oexpect ty => (ty, ty, ty) end. Module RTLtypes <: TYPE_ALGEBRA. diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index c9a6d399..051225a4 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -34,6 +34,7 @@ let precedence = function | Ebinop((Oadd|Osub|Oaddf|Osubf|Oaddfs|Osubfs|Oaddl|Osubl), _, _) -> (12, LtoR) | Ebinop((Oshl|Oshr|Oshru|Oshll|Oshrl|Oshrlu), _, _) -> (11, LtoR) | Ebinop((Ocmp _|Ocmpu _|Ocmpf _|Ocmpfs _|Ocmpl _|Ocmplu _), _, _) -> (10, LtoR) + | Ebinop((Oexpect _), _, _) -> (9, LtoR) | Ebinop((Oand|Oandl), _, _) -> (8, LtoR) | Ebinop((Oxor|Oxorl), _, _) -> (7, LtoR) | Ebinop((Oor|Oorl), _, _) -> (6, LtoR) @@ -89,6 +90,7 @@ let comparison_name = function | Cge -> ">=" let name_of_binop = function + | Oexpect _ -> "expect" | Oadd -> "+" | Osub -> "-" | Omul -> "*" diff --git a/backend/Selection.v b/backend/Selection.v index 7ba8fe92..fcb14127 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -120,6 +120,7 @@ Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := match op with + | Cminor.Oexpect ty => arg1 | Cminor.Oadd => add arg1 arg2 | Cminor.Osub => sub arg1 arg2 | Cminor.Omul => mul arg1 arg2 @@ -244,7 +245,7 @@ Function sel_known_builtin (bf: builtin_function) (args: exprlist) := match bf, args with | BI_platform b, _ => SelectOp.platform_builtin b args - | BI_standard BI_expect, a1 ::: a2 ::: Enil => Some a1 +(* | BI_standard BI_expect, a1 ::: a2 ::: Enil => Some a1 *) | BI_standard (BI_select ty), a1 ::: a2 ::: a3 ::: Enil => Some (sel_select ty a1 a2 a3) | BI_standard BI_fabs, a1 ::: Enil => diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml index 26a79fd7..5a8bde8c 100644 --- a/backend/Selectionaux.ml +++ b/backend/Selectionaux.ml @@ -39,6 +39,7 @@ let cost_unop = function | Osingleoflong | Osingleoflongu -> assert false let cost_binop = function + | Oexpect _ -> 0 | Oadd | Osub -> 1 | Omul -> 2 | Odiv | Odivu | Omod | Omodu -> assert false diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 9e0f22cc..53600c7a 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -310,46 +310,47 @@ Lemma eval_sel_binop: exists v', eval_expr tge sp e m le (sel_binop op a1 a2) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. - apply eval_add; auto. - apply eval_sub; auto. - apply eval_mul; auto. - eapply eval_divs; eauto. - eapply eval_divu; eauto. - eapply eval_mods; eauto. - eapply eval_modu; eauto. - apply eval_and; auto. - apply eval_or; auto. - apply eval_xor; auto. - apply eval_shl; auto. - apply eval_shr; auto. - apply eval_shru; auto. - apply eval_addf; auto. - apply eval_subf; auto. - apply eval_mulf; auto. - apply eval_divf; auto. - apply eval_addfs; auto. - apply eval_subfs; auto. - apply eval_mulfs; auto. - apply eval_divfs; auto. - eapply eval_addl; eauto. - eapply eval_subl; eauto. - eapply eval_mull; eauto. - eapply eval_divls; eauto. - eapply eval_divlu; eauto. - eapply eval_modls; eauto. - eapply eval_modlu; eauto. - eapply eval_andl; eauto. - eapply eval_orl; eauto. - eapply eval_xorl; eauto. - eapply eval_shll; eauto. - eapply eval_shrl; eauto. - eapply eval_shrlu; eauto. - apply eval_comp; auto. - apply eval_compu; auto. - apply eval_compf; auto. - apply eval_compfs; auto. - exists v; split; auto. eapply eval_cmpl; eauto. - exists v; split; auto. eapply eval_cmplu; eauto. + - exists v1; split; trivial. apply Val.lessdef_normalize. + - apply eval_add; auto. + - apply eval_sub; auto. + - apply eval_mul; auto. + - eapply eval_divs; eauto. + - eapply eval_divu; eauto. + - eapply eval_mods; eauto. + - eapply eval_modu; eauto. + - apply eval_and; auto. + - apply eval_or; auto. + - apply eval_xor; auto. + - apply eval_shl; auto. + - apply eval_shr; auto. + - apply eval_shru; auto. + - apply eval_addf; auto. + - apply eval_subf; auto. + - apply eval_mulf; auto. + - apply eval_divf; auto. + - apply eval_addfs; auto. + - apply eval_subfs; auto. + - apply eval_mulfs; auto. + - apply eval_divfs; auto. + - eapply eval_addl; eauto. + - eapply eval_subl; eauto. + - eapply eval_mull; eauto. + - eapply eval_divls; eauto. + - eapply eval_divlu; eauto. + - eapply eval_modls; eauto. + - eapply eval_modlu; eauto. + - eapply eval_andl; eauto. + - eapply eval_orl; eauto. + - eapply eval_xorl; eauto. + - eapply eval_shll; eauto. + - eapply eval_shrl; eauto. + - eapply eval_shrlu; eauto. + - apply eval_comp; auto. + - apply eval_compu; auto. + - apply eval_compf; auto. + - apply eval_compfs; auto. + - exists v; split; auto. eapply eval_cmpl; eauto. + - exists v; split; auto. eapply eval_cmplu; eauto. Qed. Lemma eval_sel_select: @@ -395,13 +396,13 @@ Proof. inv ARGS; try discriminate. inv H0; try discriminate. inv SEL. simpl in SEM; inv SEM. apply eval_absf; auto. -+ (* expect *) + (* + (* expect *) inv ARGS; try discriminate. inv H0; try discriminate. inv H2; try discriminate. simpl in SEM. inv SEM. inv SEL. destruct v1; destruct v0. - all: econstructor; split; eauto. + all: econstructor; split; eauto. *) - eapply eval_platform_builtin; eauto. Qed. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 5acb996d..744df818 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -1335,6 +1335,7 @@ Lemma eval_binop_compat: /\ Val.inject f v tv. Proof. destruct op; simpl; intros; inv H. +- TrivialExists. apply Val.normalize_inject; auto. - TrivialExists. apply Val.add_inject; auto. - TrivialExists. apply Val.sub_inject; auto. - TrivialExists. inv H0; inv H1; constructor. -- cgit From 06559e65f15b379949e14bb6ed1446b6fa10e9d7 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 Apr 2020 22:01:51 +0200 Subject: Oexpect in frontend --- cfrontend/Cop.v | 13 +++++++++++++ cfrontend/Cshmgen.v | 6 ++++++ cfrontend/Cshmgenproof.v | 38 ++++++++++++++++++++++---------------- cfrontend/Ctyping.v | 3 +++ cfrontend/PrintClight.ml | 1 + cfrontend/PrintCsyntax.ml | 2 ++ 6 files changed, 47 insertions(+), 16 deletions(-) diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 143e87a3..47a02851 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -33,6 +33,7 @@ Inductive unary_operation : Type := | Oabsfloat : unary_operation. (**r floating-point absolute value *) Inductive binary_operation : Type := + | Oexpect : binary_operation (**r return first argument *) | Oadd : binary_operation (**r addition (binary [+]) *) | Osub : binary_operation (**r subtraction (binary [-]) *) | Omul : binary_operation (**r multiplication (binary [*]) *) @@ -763,6 +764,14 @@ Definition sem_mul (v1:val) (t1:type) (v2: val) (t2:type) (m:mem) : option val : (fun n1 n2 => Some(Vsingle(Float32.mul n1 n2))) v1 t1 v2 t2 m. +Definition sem_expect (v1:val) (t1:type) (v2: val) (t2:type) (m:mem) : option val := + sem_binarith + (fun sg n1 n2 => Some(Vint n1)) + (fun sg n1 n2 => Some(Vlong n1)) + (fun n1 n2 => Some(Vfloat n1)) + (fun n1 n2 => Some(Vsingle n1)) + v1 t1 v2 t2 m. + Definition sem_div (v1:val) (t1:type) (v2: val) (t2:type) (m:mem) : option val := sem_binarith (fun sg n1 n2 => @@ -1050,6 +1059,7 @@ Definition sem_binary_operation (v1: val) (t1: type) (v2: val) (t2:type) (m: mem): option val := match op with + | Oexpect => sem_expect v1 t1 v2 t2 m | Oadd => sem_add cenv v1 t1 v2 t2 m | Osub => sem_sub cenv v1 t1 v2 t2 m | Omul => sem_mul v1 t1 v2 t2 m @@ -1290,6 +1300,9 @@ Lemma sem_binary_operation_inj: exists tv, sem_binary_operation cenv op tv1 ty1 tv2 ty2 m' = Some tv /\ Val.inject f v tv. Proof. unfold sem_binary_operation; intros; destruct op. +- (* expect *) + unfold sem_expect in *. + eapply sem_binarith_inject; eauto; intros; exact I. - (* add *) assert (A: forall cenv ty si v1' v2' tv1' tv2', Val.inject f v1' tv1' -> Val.inject f v2' tv2' -> diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 5bd12d00..f78b52ae 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -259,6 +259,11 @@ Definition make_add_ptr_long (ce: composite_env) (ty: type) (e1 e2: expr) := let n := make_intconst (Int.repr sz) in OK (Ebinop Oadd e1 (Ebinop Omul n (Eunop Ointoflong e2))). +Definition make_expect (e1: expr) (ty1: type) (e2: expr) (ty2: type) := + make_binarith (Oexpect AST.Tint) (Oexpect AST.Tint) + (Oexpect AST.Tfloat) (Oexpect AST.Tsingle) + (Oexpect AST.Tlong) (Oexpect AST.Tlong) e1 ty1 e2 ty2. + Definition make_add (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with | add_case_pi ty si => make_add_ptr_int ce ty si e1 e2 @@ -421,6 +426,7 @@ Definition transl_binop (ce: composite_env) (a: expr) (ta: type) (b: expr) (tb: type) : res expr := match op with + | Cop.Oexpect => make_expect a ta b tb | Cop.Oadd => make_add ce a ta b tb | Cop.Osub => make_sub ce a ta b tb | Cop.Omul => make_mul a ta b tb diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 1ceb8e4d..c5ba19d5 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -619,6 +619,11 @@ End MAKE_BIN. Hint Extern 2 (@eq (option val) _ _) => (simpl; reflexivity) : cshm. +Lemma make_expect_correct: binary_constructor_correct make_expect sem_expect. +Proof. + apply make_binarith_correct; intros; auto. +Qed. + Lemma make_add_correct: binary_constructor_correct (make_add cunit.(prog_comp_env)) (sem_add prog.(prog_comp_env)). Proof. assert (A: forall ty si a b c e le m va vb v, @@ -922,22 +927,23 @@ Lemma transl_binop_correct: eval_expr ge e le m c v. Proof. intros. destruct op; simpl in *. - eapply make_add_correct; eauto. - eapply make_sub_correct; eauto. - eapply make_mul_correct; eauto. - eapply make_div_correct; eauto. - eapply make_mod_correct; eauto. - eapply make_and_correct; eauto. - eapply make_or_correct; eauto. - eapply make_xor_correct; eauto. - eapply make_shl_correct; eauto. - eapply make_shr_correct; eauto. - eapply make_cmp_correct; eauto. - eapply make_cmp_correct; eauto. - eapply make_cmp_correct; eauto. - eapply make_cmp_correct; eauto. - eapply make_cmp_correct; eauto. - eapply make_cmp_correct; eauto. +- eapply make_expect_correct; eauto. +- eapply make_add_correct; eauto. +- eapply make_sub_correct; eauto. +- eapply make_mul_correct; eauto. +- eapply make_div_correct; eauto. +- eapply make_mod_correct; eauto. +- eapply make_and_correct; eauto. +- eapply make_or_correct; eauto. +- eapply make_xor_correct; eauto. +- eapply make_shl_correct; eauto. +- eapply make_shr_correct; eauto. +- eapply make_cmp_correct; eauto. +- eapply make_cmp_correct; eauto. +- eapply make_cmp_correct; eauto. +- eapply make_cmp_correct; eauto. +- eapply make_cmp_correct; eauto. +- eapply make_cmp_correct; eauto. Qed. Lemma make_load_correct: diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 00fcf8ab..bde4001f 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -111,6 +111,7 @@ Definition comparison_type (ty1 ty2: type) (m: string): res type := Definition type_binop (op: binary_operation) (ty1 ty2: type) : res type := match op with + | Oexpect => binarith_type ty1 ty2 "__builtin_expect" | Oadd => match classify_add ty1 ty2 with | add_case_pi ty _ | add_case_ip _ ty @@ -1546,6 +1547,8 @@ Lemma pres_sem_binop: Proof. intros until m; intros TY SEM WT1 WT2. destruct op; simpl in TY; simpl in SEM. +- (* expect *) + unfold sem_expect in SEM. eapply pres_sem_binarith; eauto; intros; exact I. - (* add *) unfold sem_add, sem_add_ptr_int, sem_add_ptr_long in SEM; DestructCases; auto with ty. eapply pres_sem_binarith; eauto; intros; exact I. diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index 0e735d2d..0aefde31 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -62,6 +62,7 @@ let precedence = function | Ebinop(Oand, _, _, _) -> (8, LtoR) | Ebinop(Oxor, _, _, _) -> (7, LtoR) | Ebinop(Oor, _, _, _) -> (6, LtoR) + | Ebinop(Oexpect, _, _, _) -> (5, LtoR) (* Expressions *) diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 03dc5837..beca056f 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -30,6 +30,7 @@ let name_unop = function | Oabsfloat -> "__builtin_fabs" let name_binop = function + | Oexpect -> "expect" | Oadd -> "+" | Osub -> "-" | Omul -> "*" @@ -158,6 +159,7 @@ let rec precedence = function | Ebinop(Oand, _, _, _) -> (8, LtoR) | Ebinop(Oxor, _, _, _) -> (7, LtoR) | Ebinop(Oor, _, _, _) -> (6, LtoR) + | Ebinop(Oexpect, _, _, _) -> (5, LtoR) (* fixme *) | Eseqand _ -> (5, LtoR) | Eseqor _ -> (4, LtoR) | Econdition _ -> (3, RtoL) -- cgit From 3b15828ca868365b285ba611ba72177e90d0061b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 Apr 2020 22:50:20 +0200 Subject: expect operation --- cfrontend/C2C.ml | 8 +++++++ cfrontend/SimplExprspec.v | 54 +++++++++++++++++++++++------------------------ common/Builtins0.v | 12 +++++------ 3 files changed, 41 insertions(+), 33 deletions(-) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 9f2c4604..902a5c5d 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -900,6 +900,14 @@ let rec convertExpr env e = | C.ECompound(ty1, ie) -> unsupported "compound literals"; ezero + | C.ECall({edesc = C.EVar {name = "__builtin_expect"}}, args) -> + (match args with + | [e1; e2] -> + ewrap (Ctyping.ebinop Cop.Oexpect (convertExpr env e1) (convertExpr env e2)) + | _ -> + error "__builtin_expect wants two arguments"; + ezero) + | C.ECall({edesc = C.EVar {name = "__builtin_debug"}}, args) when List.length args < 2 -> error "too few arguments to function call, expected at least 2, have 0"; ezero diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index e7d57a1c..95e3957c 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -770,53 +770,53 @@ Proof. (* val *) simpl in H. destruct v; monadInv H; exists (@nil ident); split; auto with gensym. Opaque makeif. - intros. destruct dst; simpl in *; inv H2. +- intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. - intros. destruct dst; simpl in *; inv H2. +- intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. - intros. destruct dst; simpl in *; inv H2. +- intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. - intros. destruct dst; simpl in *; inv H2. +- intros. destruct dst; simpl in *; inv H2. constructor. auto. intros; constructor. constructor. constructor. auto. intros; constructor. (* var *) - monadInv H; econstructor; split; auto with gensym. UseFinish. constructor. +- monadInv H; econstructor; split; auto with gensym. UseFinish. constructor. (* field *) - monadInv H0. exploit H; eauto. auto. intros [tmp [A B]]. UseFinish. +- monadInv H0. exploit H; eauto. auto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. (* valof *) - monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. exploit transl_valof_meets_spec; eauto. intros [tmp2 [Csyntax D]]. UseFinish. exists (tmp1 ++ tmp2); split. intros; apply tr_expr_add_dest. econstructor; eauto with gensym. eauto with gensym. (* deref *) - monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. (* addrof *) - monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. econstructor; eauto. (* unop *) - monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. (* binop *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. UseFinish. exists (tmp1 ++ tmp2); split. intros; apply tr_expr_add_dest. econstructor; eauto with gensym. eauto with gensym. (* cast *) - monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. +- monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. intros; apply tr_expr_add_dest. constructor; auto. (* seqand *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. (* for value *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. @@ -840,7 +840,7 @@ Opaque makeif. apply list_disjoint_cons_r; eauto with gensym. apply contained_app; eauto with gensym. (* seqor *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. (* for value *) exploit H0; eauto with gensym. intros [tmp2 [Csyntax D]]. @@ -864,7 +864,7 @@ Opaque makeif. apply list_disjoint_cons_r; eauto with gensym. apply contained_app; eauto with gensym. (* condition *) - monadInv H2. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H2. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0. (* for value *) exploit H0; eauto with gensym. intros [tmp2 [C D]]. @@ -896,13 +896,13 @@ Opaque makeif. apply contained_app; eauto with gensym. apply contained_app; eauto with gensym. (* sizeof *) - monadInv H. UseFinish. +- monadInv H. UseFinish. exists (@nil ident); split; auto with gensym. constructor. (* alignof *) - monadInv H. UseFinish. +- monadInv H. UseFinish. exists (@nil ident); split; auto with gensym. constructor. (* assign *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. destruct dst; monadInv EQ2; simpl add_dest in *. (* for value *) @@ -921,7 +921,7 @@ Opaque makeif. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. (* assignop *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. exploit transl_valof_meets_spec; eauto. intros [tmp3 [E F]]. destruct dst; monadInv EQ3; simpl add_dest in *. @@ -941,7 +941,7 @@ Opaque makeif. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. (* postincr *) - monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0; simpl add_dest in *. (* for value *) exists (x0 :: tmp1); split. @@ -958,7 +958,7 @@ Opaque makeif. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. (* comma *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto with gensym. intros [tmp2 [Csyntax D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. @@ -968,7 +968,7 @@ Opaque makeif. destruct dst; simpl; auto with gensym. apply contained_app; eauto with gensym. (* call *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. destruct dst; monadInv EQ2; simpl add_dest in *. (* for value *) @@ -986,7 +986,7 @@ Opaque makeif. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. (* builtin *) - monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. destruct dst; monadInv EQ0; simpl add_dest in *. (* for value *) exists (x0 :: tmp1); split. @@ -1001,13 +1001,13 @@ Opaque makeif. repeat rewrite app_ass. econstructor; eauto with gensym. congruence. apply contained_cons; eauto with gensym. (* loc *) - monadInv H. +- monadInv H. (* paren *) - monadInv H0. +- monadInv H0. (* nil *) - monadInv H; exists (@nil ident); split; auto with gensym. constructor. +- monadInv H; exists (@nil ident); split; auto with gensym. constructor. (* cons *) - monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. +- monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. diff --git a/common/Builtins0.v b/common/Builtins0.v index a3215545..f72febf8 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -337,7 +337,7 @@ Inductive standard_builtin : Type := | BI_addl | BI_subl | BI_mull - | BI_expect +(* | BI_expect *) | BI_i16_bswap | BI_i32_bswap | BI_i64_bswap @@ -370,7 +370,7 @@ Definition standard_builtin_table : list (string * standard_builtin) := :: ("__builtin_addl", BI_addl) :: ("__builtin_subl", BI_subl) :: ("__builtin_mull", BI_mull) - :: ("__builtin_expect", BI_expect) +(* :: ("__builtin_expect", BI_expect) *) :: ("__builtin_bswap16", BI_i16_bswap) :: ("__builtin_bswap", BI_i32_bswap) :: ("__builtin_bswap32", BI_i32_bswap) @@ -405,8 +405,8 @@ Definition standard_builtin_sig (b: standard_builtin) : signature := mksignature (Tlong :: Tlong :: nil) Tlong cc_default | BI_mull => mksignature (Tint :: Tint :: nil) Tlong cc_default - | BI_expect => - mksignature (Tlong :: Tlong :: nil) Tlong cc_default +(* | BI_expect => + mksignature (Tlong :: Tlong :: nil) Tlong cc_default *) | BI_i32_bswap => mksignature (Tint :: nil) Tint cc_default | BI_i64_bswap => @@ -437,8 +437,8 @@ Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _ | BI_subl => mkbuiltin_v2t Tlong Val.subl _ _ | BI_mull => mkbuiltin_v2t Tlong Val.mull' _ _ - | BI_expect => - mkbuiltin_n2t Tlong Tlong Tlong (fun x _ => x) +(* | BI_expect => + mkbuiltin_n2t Tlong Tlong Tlong (fun x _ => x) *) | BI_i16_bswap => mkbuiltin_n1t Tint Tint (fun n => Int.repr (decode_int (List.rev (encode_int 2%nat (Int.unsigned n))))) -- cgit From 952a5faf13280e9bed6fe10670561d7e4fe5bc19 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 7 Apr 2020 23:33:53 +0200 Subject: __builtin_expect seems to work --- backend/CminorSel.v | 8 ++++---- backend/RTLgen.v | 4 ++-- backend/RTLgenaux.ml | 2 +- backend/RTLgenproof.v | 4 ++-- backend/RTLgenspec.v | 4 ++-- backend/Selection.v | 41 ++++++++++++++++++++++++++++++----------- backend/Selectionproof.v | 6 +++--- backend/SplitLong.vp | 5 +++-- 8 files changed, 47 insertions(+), 27 deletions(-) diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 96cb8ae6..26f47e23 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -50,7 +50,7 @@ with exprlist : Type := | Econs: expr -> exprlist -> exprlist with condexpr : Type := - | CEcond : condition -> exprlist -> condexpr + | CEcond : condition -> option bool -> exprlist -> condexpr | CEcondition : condexpr -> condexpr -> condexpr -> condexpr | CElet: expr -> condexpr -> condexpr. @@ -207,10 +207,10 @@ with eval_exprlist: letenv -> exprlist -> list val -> Prop := eval_exprlist le (Econs a1 al) (v1 :: vl) with eval_condexpr: letenv -> condexpr -> bool -> Prop := - | eval_CEcond: forall le cond al vl vb, + | eval_CEcond: forall le cond expected al vl vb, eval_exprlist le al vl -> eval_condition cond vl m = Some vb -> - eval_condexpr le (CEcond cond al) vb + eval_condexpr le (CEcond cond expected al) vb | eval_CEcondition: forall le a b c va v, eval_condexpr le a va -> eval_condexpr le (if va then b else c) v -> @@ -495,7 +495,7 @@ with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist := with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := match a with - | CEcond c al => CEcond c (lift_exprlist p al) + | CEcond c expected al => CEcond c expected (lift_exprlist p al) | CEcondition a b c => CEcondition (lift_condexpr p a) (lift_condexpr p b) (lift_condexpr p c) | CElet a b => CElet (lift_expr p a) (lift_condexpr (S p) b) end. diff --git a/backend/RTLgen.v b/backend/RTLgen.v index ac98f3a1..243d7b7c 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -477,9 +477,9 @@ with transl_exprlist (map: mapping) (al: exprlist) (rl: list reg) (nd: node) with transl_condexpr (map: mapping) (a: condexpr) (ntrue nfalse: node) {struct a} : mon node := match a with - | CEcond c al => + | CEcond c expected al => do rl <- alloc_regs map al; - do nt <- add_instr (Icond c rl ntrue nfalse None); + do nt <- add_instr (Icond c rl ntrue nfalse expected); transl_exprlist map al rl nt | CEcondition a b c => do nc <- transl_condexpr map c ntrue nfalse; diff --git a/backend/RTLgenaux.ml b/backend/RTLgenaux.ml index e39d3b56..26688e23 100644 --- a/backend/RTLgenaux.ml +++ b/backend/RTLgenaux.ml @@ -41,7 +41,7 @@ and size_exprs = function | Econs(e1, el) -> size_expr e1 + size_exprs el and size_condexpr = function - | CEcond(c, args) -> size_exprs args + | CEcond(c, expected, args) -> size_exprs args | CEcondition(c1, c2, c3) -> 1 + size_condexpr c1 + size_condexpr c2 + size_condexpr c3 | CElet(a, c) -> diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index b94ec22f..e62aff22 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -799,11 +799,11 @@ Proof. Qed. Lemma transl_condexpr_CEcond_correct: - forall le cond al vl vb, + forall le cond expected al vl vb, eval_exprlist ge sp e m le al vl -> transl_exprlist_prop le al vl -> eval_condition cond vl m = Some vb -> - transl_condexpr_prop le (CEcond cond al) vb. + transl_condexpr_prop le (CEcond cond expected al) vb. Proof. intros; red; intros. inv TE. exploit H0; eauto. intros [rs1 [tm1 [EX1 [ME1 [RES1 [OTHER1 EXT1]]]]]]. diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 30ad7d82..36b8409d 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -744,10 +744,10 @@ Inductive tr_expr (c: code): with tr_condition (c: code): mapping -> list reg -> condexpr -> node -> node -> node -> Prop := - | tr_CEcond: forall map pr cond bl ns ntrue nfalse n1 rl i, + | tr_CEcond: forall map pr cond expected bl ns ntrue nfalse n1 rl i, tr_exprlist c map pr bl ns n1 rl -> c!n1 = Some (Icond cond rl ntrue nfalse i) -> - tr_condition c map pr (CEcond cond bl) ns ntrue nfalse + tr_condition c map pr (CEcond cond expected bl) ns ntrue nfalse | tr_CEcondition: forall map pr a1 a2 a3 ns ntrue nfalse n2 n3, tr_condition c map pr a1 ns n2 n3 -> tr_condition c map pr a2 n2 ntrue nfalse -> diff --git a/backend/Selection.v b/backend/Selection.v index fcb14127..342bd8ca 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -35,12 +35,13 @@ Local Open Scope error_monad_scope. (** Conversion of conditions *) -Function condexpr_of_expr (e: expr) : condexpr := +Function condexpr_of_expr (e: expr) (expected : option bool) : condexpr := match e with - | Eop (Ocmp c) el => CEcond c el - | Econdition a b c => CEcondition a (condexpr_of_expr b) (condexpr_of_expr c) - | Elet a b => CElet a (condexpr_of_expr b) - | _ => CEcond (Ccompuimm Cne Int.zero) (e ::: Enil) + | Eop (Ocmp c) el => CEcond c expected el + | Econdition a b c => CEcondition a (condexpr_of_expr b expected) + (condexpr_of_expr c expected) + | Elet a b => CElet a (condexpr_of_expr b expected) + | _ => CEcond (Ccompuimm Cne Int.zero) expected (e ::: Enil) end. Function condition_of_expr (e: expr) : condition * exprlist := @@ -167,7 +168,7 @@ Definition sel_select (ty: typ) (cnd ifso ifnot: expr) : expr := let (cond, args) := condition_of_expr cnd in match SelectOp.select ty cond args ifso ifnot with | Some a => a - | None => Econdition (condexpr_of_expr cnd) ifso ifnot + | None => Econdition (condexpr_of_expr cnd None) ifso ifnot end. (** Conversion from Cminor expression to Cminorsel expressions *) @@ -293,16 +294,16 @@ Fixpoint sel_switch (arg: nat) (t: comptree): exitexpr := | CTaction act => XEexit act | CTifeq key act t' => - XEcondition (condexpr_of_expr (make_cmp_eq (Eletvar arg) key)) + XEcondition (condexpr_of_expr (make_cmp_eq (Eletvar arg) key) None) (XEexit act) (sel_switch arg t') | CTiflt key t1 t2 => - XEcondition (condexpr_of_expr (make_cmp_ltu (Eletvar arg) key)) + XEcondition (condexpr_of_expr (make_cmp_ltu (Eletvar arg) key) None) (sel_switch arg t1) (sel_switch arg t2) | CTjumptable ofs sz tbl t' => XElet (make_sub (Eletvar arg) ofs) - (XEcondition (condexpr_of_expr (make_cmp_ltu (Eletvar O) sz)) + (XEcondition (condexpr_of_expr (make_cmp_ltu (Eletvar O) sz) None) (XEjumptable (make_to_int (Eletvar O)) tbl) (sel_switch (S arg) t')) end. @@ -377,6 +378,22 @@ Definition if_conversion | _, _ => None end. +Definition extract_expect1 (e : Cminor.expr) : option bool := + match e with + | Cminor.Ebinop (Cminor.Oexpect ty) e1 (Cminor.Econst (Cminor.Ointconst c)) => + Some (if Int.eq_dec c Int.zero then false else true) + | Cminor.Ebinop (Cminor.Oexpect ty) e1 (Cminor.Econst (Cminor.Olongconst c)) => + Some (if Int64.eq_dec c Int64.zero then false else true) + | _ => None + end. + +Definition extract_expect (e : Cminor.expr) : option bool := + match e with + | Cminor.Ebinop (Cminor.Ocmpu Cne) e1 (Cminor.Econst (Cminor.Ointconst c)) => + if Int.eq_dec c Int.zero then extract_expect1 e1 else None + | _ => extract_expect1 e + end. + (** Conversion from Cminor statements to Cminorsel statements. *) Fixpoint sel_stmt (ki: known_idents) (env: typenv) (s: Cminor.stmt) : res stmt := @@ -404,8 +421,10 @@ Fixpoint sel_stmt (ki: known_idents) (env: typenv) (s: Cminor.stmt) : res stmt : match if_conversion ki env e ifso ifnot with | Some s => OK s | None => - do ifso' <- sel_stmt ki env ifso; do ifnot' <- sel_stmt ki env ifnot; - OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot') + do ifso' <- sel_stmt ki env ifso; + do ifnot' <- sel_stmt ki env ifnot; + OK (Sifthenelse (condexpr_of_expr (sel_expr e) + (extract_expect e)) ifso' ifnot') end | Cminor.Sloop body => do body' <- sel_stmt ki env body; OK (Sloop body') diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 53600c7a..955c45a4 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -196,12 +196,12 @@ Variable e: env. Variable m: mem. Lemma eval_condexpr_of_expr: - forall a le v b, + forall expected a le v b, eval_expr tge sp e m le a v -> Val.bool_of_val v b -> - eval_condexpr tge sp e m le (condexpr_of_expr a) b. + eval_condexpr tge sp e m le (condexpr_of_expr a expected) b. Proof. - intros until a. functional induction (condexpr_of_expr a); intros. + intros until a. functional induction (condexpr_of_expr a expected); intros. (* compare *) inv H. econstructor; eauto. simpl in H6. inv H6. apply Val.bool_of_val_of_optbool. auto. diff --git a/backend/SplitLong.vp b/backend/SplitLong.vp index dfe42df0..0f240602 100644 --- a/backend/SplitLong.vp +++ b/backend/SplitLong.vp @@ -10,6 +10,7 @@ (* *) (* *********************************************************************) +(* FIXME: expected branching information not propagated *) (** Instruction selection for 64-bit integer operations *) Require String. @@ -256,7 +257,7 @@ Definition cmpl_ne_zero (e: expr) := Definition cmplu_gen (ch cl: comparison) (e1 e2: expr) := splitlong2 e1 e2 (fun h1 l1 h2 l2 => - Econdition (CEcond (Ccomp Ceq) (h1:::h2:::Enil)) + Econdition (CEcond (Ccomp Ceq) None (h1:::h2:::Enil)) (Eop (Ocmp (Ccompu cl)) (l1:::l2:::Enil)) (Eop (Ocmp (Ccompu ch)) (h1:::h2:::Enil))). @@ -278,7 +279,7 @@ Definition cmplu (c: comparison) (e1 e2: expr) := Definition cmpl_gen (ch cl: comparison) (e1 e2: expr) := splitlong2 e1 e2 (fun h1 l1 h2 l2 => - Econdition (CEcond (Ccomp Ceq) (h1:::h2:::Enil)) + Econdition (CEcond (Ccomp Ceq) None (h1:::h2:::Enil)) (Eop (Ocmp (Ccompu cl)) (l1:::l2:::Enil)) (Eop (Ocmp (Ccomp ch)) (h1:::h2:::Enil))). -- cgit From 50527aedadd5d3c77b15ddbc3a08f189d01d53c1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 07:01:58 +0200 Subject: bumped for Coq 8.11.1 --- common/Builtins0.v | 6 ------ configure | 2 +- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/common/Builtins0.v b/common/Builtins0.v index f72febf8..8da98314 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -337,7 +337,6 @@ Inductive standard_builtin : Type := | BI_addl | BI_subl | BI_mull -(* | BI_expect *) | BI_i16_bswap | BI_i32_bswap | BI_i64_bswap @@ -370,7 +369,6 @@ Definition standard_builtin_table : list (string * standard_builtin) := :: ("__builtin_addl", BI_addl) :: ("__builtin_subl", BI_subl) :: ("__builtin_mull", BI_mull) -(* :: ("__builtin_expect", BI_expect) *) :: ("__builtin_bswap16", BI_i16_bswap) :: ("__builtin_bswap", BI_i32_bswap) :: ("__builtin_bswap32", BI_i32_bswap) @@ -405,8 +403,6 @@ Definition standard_builtin_sig (b: standard_builtin) : signature := mksignature (Tlong :: Tlong :: nil) Tlong cc_default | BI_mull => mksignature (Tint :: Tint :: nil) Tlong cc_default -(* | BI_expect => - mksignature (Tlong :: Tlong :: nil) Tlong cc_default *) | BI_i32_bswap => mksignature (Tint :: nil) Tint cc_default | BI_i64_bswap => @@ -437,8 +433,6 @@ Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _ | BI_subl => mkbuiltin_v2t Tlong Val.subl _ _ | BI_mull => mkbuiltin_v2t Tlong Val.mull' _ _ -(* | BI_expect => - mkbuiltin_n2t Tlong Tlong Tlong (fun x _ => x) *) | BI_i16_bswap => mkbuiltin_n1t Tint Tint (fun n => Int.repr (decode_int (List.rev (encode_int 2%nat (Int.unsigned n))))) diff --git a/configure b/configure index f790281c..cb2f52ba 100755 --- a/configure +++ b/configure @@ -568,7 +568,7 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0) + 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" -- cgit From 299ee78f478cb7a042c76b3bdd58eac62d41a015 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 07:23:39 +0200 Subject: force using coq 8.10 --- .gitlab-ci.yml | 22 +++++++++++----------- configure | 2 +- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1f854fc3..069b9012 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,7 +3,7 @@ stages: check-admitted: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - opam switch 4.07.1+flambda - eval `opam config env` @@ -22,7 +22,7 @@ check-admitted: build_x86_64: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - opam switch 4.07.1+flambda - eval `opam config env` @@ -43,7 +43,7 @@ build_x86_64: build_ia32: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-multilib @@ -66,7 +66,7 @@ build_ia32: build_aarch64: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user @@ -89,7 +89,7 @@ build_aarch64: build_arm: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user @@ -113,7 +113,7 @@ build_arm: build_armhf: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user @@ -136,7 +136,7 @@ build_armhf: build_ppc: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user @@ -157,7 +157,7 @@ build_ppc: build_ppc64: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc64-linux-gnu @@ -178,7 +178,7 @@ build_ppc64: build_rv64: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -201,7 +201,7 @@ build_rv64: build_rv32: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -222,7 +222,7 @@ build_rv32: build_k1c: stage: build - image: "coqorg/coq" + image: "coqorg/coq:8.10" before_script: - opam switch 4.07.1+flambda - eval `opam config env` diff --git a/configure b/configure index cb2f52ba..f790281c 100755 --- a/configure +++ b/configure @@ -568,7 +568,7 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1) + 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" -- cgit From 6e64e970a706c45b5b236a0e4f92698e22682344 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 07:56:33 +0200 Subject: adapt the other targets for the new field in CEcond --- powerpc/SelectOp.vp | 2 +- x86/SelectOp.vp | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 50b1bdd6..52f4f855 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -472,7 +472,7 @@ Definition intuoffloat (e: expr) := else Elet e (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) - (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) + (Econdition (CEcond (Ccompf Clt) None (Eletvar 1 ::: Eletvar 0 ::: Enil)) (intoffloat (Eletvar 1)) (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat. diff --git a/x86/SelectOp.vp b/x86/SelectOp.vp index a23c37d5..2a09207b 100644 --- a/x86/SelectOp.vp +++ b/x86/SelectOp.vp @@ -503,7 +503,7 @@ Definition intuoffloat (e: expr) := if Archi.splitlong then Elet e (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil) - (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil)) + (Econdition (CEcond (Ccompf Clt) None (Eletvar 1 ::: Eletvar 0 ::: Enil)) (intoffloat (Eletvar 1)) (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat else @@ -516,7 +516,7 @@ Nondetfunction floatofintu (e: expr) := if Archi.splitlong then let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in Elet e - (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil)) + (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) None (Eletvar O ::: Enil)) (floatofint (Eletvar O)) (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f)) else -- cgit From 7d60bff91b1ede7475f703f2d9eb926d11345bf9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 08:51:28 +0200 Subject: accept Coq 8.11.1 --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index f790281c..cb2f52ba 100755 --- a/configure +++ b/configure @@ -568,7 +568,7 @@ missingtools=false echo "Testing Coq... " | tr -d '\n' coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p') case "$coq_ver" in - 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0) + 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1) echo "version $coq_ver -- good!";; ?*) echo "version $coq_ver -- UNSUPPORTED" -- cgit From 84c5408706feb748cf364efcbe6a67512d622f40 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 09:49:24 +0200 Subject: added EF_profiling --- backend/CSE.v | 2 +- backend/CSEproof.v | 1 + cfrontend/Cexec.v | 9 +++++++ common/AST.v | 10 +++++++- common/Events.v | 65 +++++++++++++++++++++++++++++++++++++++++---------- common/PrintAST.ml | 4 +++- mppa_k1c/Asmexpand.ml | 1 + 7 files changed, 77 insertions(+), 15 deletions(-) diff --git a/backend/CSE.v b/backend/CSE.v index 1936d4e4..9ba50a34 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -493,7 +493,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb | _ => empty_numbering end - | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ => + | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ | EF_profiling _ => set_res_unknown before res end | Icond cond args ifso ifnot _ => diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 5bbb7508..a7465cee 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -1318,6 +1318,7 @@ Proof. + apply CASE2; inv H1; auto. + apply CASE1. + apply CASE2; inv H1; auto. + + apply CASE2; inv H1; auto. * apply set_res_lessdef; auto. - (* Icond *) diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index b08c3ad7..609689a7 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -509,6 +509,10 @@ Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := Some(w, E0, Vundef, m). +Definition do_ef_profiling (id : profiling_id) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + Some(w, E0, Vundef, m). + Definition do_builtin_or_external (name: string) (sg: signature) (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := match lookup_builtin_function name sg with @@ -531,6 +535,7 @@ Definition do_external (ef: external_function): | EF_annot_val kind text targ => do_ef_annot_val text targ | EF_inline_asm text sg clob => do_inline_assembly text sg ge | EF_debug kind text targs => do_ef_debug kind text targs + | EF_profiling id => do_ef_profiling id end. Lemma do_ef_external_sound: @@ -598,6 +603,8 @@ Proof with try congruence. eapply do_inline_assembly_sound; eauto. - (* EF_debug *) unfold do_ef_debug. mydestr. split; constructor. +- (* EF_profiling *) + unfold do_ef_profiling. mydestr. split; constructor. Qed. Lemma do_ef_external_complete: @@ -652,6 +659,8 @@ Proof. eapply do_inline_assembly_complete; eauto. - (* EF_debug *) inv H. inv H0. reflexivity. +- (* EF_profiling *) + inv H. inv H0. reflexivity. Qed. (** * Reduction of expressions *) diff --git a/common/AST.v b/common/AST.v index eb34d675..595ace01 100644 --- a/common/AST.v +++ b/common/AST.v @@ -464,6 +464,9 @@ Qed. (** * External functions *) +(* Identifiers for profiling information *) +Definition profiling_id := Z.t. + (** For most languages, the functions composing the program are either internal functions, defined within the language, or external functions, defined outside. External functions include system calls but also @@ -514,10 +517,13 @@ Inductive external_function : Type := used with caution, as it can invalidate the semantic preservation theorem. Generated only if [-finline-asm] is given. *) - | EF_debug (kind: positive) (text: ident) (targs: list typ). + | EF_debug (kind: positive) (text: ident) (targs: list typ) (** Transport debugging information from the front-end to the generated assembly. Takes zero, one or several arguments like [EF_annot]. Unlike [EF_annot], produces no observable event. *) + | EF_profiling (id: profiling_id). + (** Count one profiling event for this identifier. + Takes no argument. Produces no observable event. *) (** The type signature of an external function. *) @@ -535,6 +541,7 @@ Definition ef_sig (ef: external_function): signature := | EF_annot_val kind text targ => mksignature (targ :: nil) targ cc_default | EF_inline_asm text sg clob => sg | EF_debug kind text targs => mksignature targs Tvoid cc_default + | EF_profiling id => mksignature nil Tvoid cc_default end. (** Whether an external function should be inlined by the compiler. *) @@ -553,6 +560,7 @@ Definition ef_inline (ef: external_function) : bool := | EF_annot_val kind Text rg => true | EF_inline_asm text sg clob => true | EF_debug kind text targs => true + | EF_profiling id => true end. (** Whether an external function must reload its arguments. *) diff --git a/common/Events.v b/common/Events.v index 28bb992a..16efd89c 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1378,6 +1378,11 @@ Inductive extcall_debug_sem (ge: Senv.t): | extcall_debug_sem_intro: forall vargs m, extcall_debug_sem ge vargs m E0 Vundef m. +Inductive extcall_profiling_sem (ge: Senv.t): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_profiling_sem_intro: forall vargs m, + extcall_profiling_sem ge vargs m E0 Vundef m. + Lemma extcall_debug_ok: forall targs, extcall_properties extcall_debug_sem @@ -1412,6 +1417,40 @@ Proof. split. constructor. auto. Qed. +Lemma extcall_profiling_ok: + forall targs, + extcall_properties extcall_profiling_sem + (mksignature targs Tvoid cc_default). +Proof. + intros; constructor; intros. +(* well typed *) +- inv H. simpl. auto. +(* symbols *) +- inv H0. econstructor; eauto. +(* valid blocks *) +- inv H; auto. +(* perms *) +- inv H; auto. +(* readonly *) +- inv H; auto. +(* mem extends *) +- inv H. + exists Vundef; exists m1'; intuition. + econstructor; eauto. +(* mem injects *) +- inv H0. + exists f; exists Vundef; exists m1'; intuition. + econstructor; eauto. + red; intros; congruence. +(* trace length *) +- inv H; simpl; omega. +(* receptive *) +- inv H; inv H0. exists Vundef, m1; constructor. +(* determ *) +- inv H; inv H0. + split. constructor. auto. +Qed. + (** ** Semantics of known built-in functions. *) (** Some built-in functions and runtime support functions have known semantics @@ -1530,6 +1569,7 @@ Definition external_call (ef: external_function): extcall_sem := | EF_annot_val kind txt targ => extcall_annot_val_sem txt targ | EF_inline_asm txt sg clb => inline_assembly_sem txt sg | EF_debug kind txt targs => extcall_debug_sem + | EF_profiling id => extcall_profiling_sem end. Theorem external_call_spec: @@ -1537,18 +1577,19 @@ Theorem external_call_spec: extcall_properties (external_call ef) (ef_sig ef). Proof. intros. unfold external_call, ef_sig; destruct ef. - apply external_functions_properties. - apply builtin_or_external_sem_ok. - apply builtin_or_external_sem_ok. - apply volatile_load_ok. - apply volatile_store_ok. - apply extcall_malloc_ok. - apply extcall_free_ok. - apply extcall_memcpy_ok. - apply extcall_annot_ok. - apply extcall_annot_val_ok. - apply inline_assembly_properties. - apply extcall_debug_ok. +- apply external_functions_properties. +- apply builtin_or_external_sem_ok. +- apply builtin_or_external_sem_ok. +- apply volatile_load_ok. +- apply volatile_store_ok. +- apply extcall_malloc_ok. +- apply extcall_free_ok. +- apply extcall_memcpy_ok. +- apply extcall_annot_ok. +- apply extcall_annot_val_ok. +- apply inline_assembly_properties. +- apply extcall_debug_ok. +- apply extcall_profiling_ok. Qed. Definition external_call_well_typed_gen ef := ec_well_typed (external_call_spec ef). diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 3f718428..7f15bc91 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -61,7 +61,9 @@ let name_of_external = function | EF_annot_val(kind,text, targ) -> sprintf "annot_val %S" (camlstring_of_coqstring text) | EF_inline_asm(text, sg, clob) -> sprintf "inline_asm %S" (camlstring_of_coqstring text) | EF_debug(kind, text, targs) -> - sprintf "debug%d %S" (P.to_int kind) (extern_atom text) + sprintf "debug%d %S" (P.to_int kind) (extern_atom text) + | EF_profiling(id) -> + sprintf "profiling %LX" (Z.to_int64 id) let rec print_builtin_arg px oc = function | BA x -> px oc x diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index 8ab10bc5..e388d2aa 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -591,6 +591,7 @@ let expand_instruction instr = | EF_external _ -> failwith "asmexpand: external" | EF_inline_asm _ -> emit instr | EF_runtime _ -> failwith "asmexpand: runtime" + | EF_profiling _ -> emit instr end | _ -> emit instr -- cgit From 66f700d36891a90983bb97d245e04a2e97913c7d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 10:52:02 +0200 Subject: begin profiling stuff --- backend/Profiling.v | 57 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 backend/Profiling.v diff --git a/backend/Profiling.v b/backend/Profiling.v new file mode 100644 index 00000000..ce0e4e38 --- /dev/null +++ b/backend/Profiling.v @@ -0,0 +1,57 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. + +Local Open Scope positive. + +Definition inject_profiling_call (prog : code) + (pc extra_pc ifso ifnot : node) : node * code := + let extra_pc' := Pos.succ extra_pc in + let prog' := PTree.set extra_pc + (Ibuiltin (EF_profiling 0%Z) nil BR_none ifso) prog in + let prog'':= PTree.set extra_pc' + (Ibuiltin (EF_profiling 0%Z) nil BR_none ifnot) prog' in + (Pos.succ extra_pc', prog''). + +Definition inject_at (prog : code) (pc extra_pc : node) : node * code := + match PTree.get pc prog with + | Some (Icond cond args ifso ifnot expected) => + inject_profiling_call + (PTree.set pc + (Icond cond args extra_pc (Pos.succ extra_pc) expected) prog) + pc extra_pc ifso ifnot + | _ => inject_profiling_call prog pc extra_pc 1 1 (* does not happen *) + end. + +Definition inject_at' (already : node * code) pc := + let (extra_pc, prog) := already in + inject_at prog pc extra_pc. + +Definition inject_l (prog : code) extra_pc injections := + List.fold_left (fun already (inject_pc : node) => + inject_at' already inject_pc) + injections + (extra_pc, prog). + +Definition gen_conditions (prog : code) := + List.map fst (PTree.elements (PTree.filter1 + (fun instr => + match instr with + | Icond cond args ifso ifnot expected => true + | _ => false + end) prog)). + +Definition transf_function (f : function) : function := + let max_pc := max_pc_function f in + let conditions := gen_conditions (fn_code f) in + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := snd (inject_l (fn_code f) (Pos.succ max_pc) conditions); + fn_entrypoint := f.(fn_entrypoint) |}. + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. -- cgit From 1972df30827022dcb39110cddf9032eaa3dc61b9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 11:35:17 +0200 Subject: begin installing profiling --- Makefile | 1 + backend/CSE.v | 2 +- backend/Profiling.v | 97 +++++++++++++++++++++++++++++------------------------ cfrontend/Cexec.v | 2 +- common/AST.v | 9 ++--- common/Events.v | 2 +- common/PrintAST.ml | 4 +-- driver/Clflags.ml | 3 ++ driver/Compopts.v | 3 ++ driver/Driver.ml | 4 ++- 10 files changed, 73 insertions(+), 54 deletions(-) diff --git a/Makefile b/Makefile index 2cd40800..cad61d9d 100644 --- a/Makefile +++ b/Makefile @@ -79,6 +79,7 @@ BACKEND=\ RTLgen.v RTLgenspec.v RTLgenproof.v \ Tailcall.v Tailcallproof.v \ Inlining.v Inliningspec.v Inliningproof.v \ + Profiling.v Profilingproof.v \ Renumber.v Renumberproof.v \ Duplicate.v Duplicateproof.v \ RTLtyping.v \ diff --git a/backend/CSE.v b/backend/CSE.v index 9ba50a34..838d96a6 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -493,7 +493,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb | _ => empty_numbering end - | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ | EF_profiling _ => + | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ | EF_profiling _ _ => set_res_unknown before res end | Icond cond args ifso ifnot _ => diff --git a/backend/Profiling.v b/backend/Profiling.v index ce0e4e38..4995c507 100644 --- a/backend/Profiling.v +++ b/backend/Profiling.v @@ -4,54 +4,63 @@ Require Import Memory Registers Op RTL. Local Open Scope positive. -Definition inject_profiling_call (prog : code) - (pc extra_pc ifso ifnot : node) : node * code := - let extra_pc' := Pos.succ extra_pc in - let prog' := PTree.set extra_pc - (Ibuiltin (EF_profiling 0%Z) nil BR_none ifso) prog in - let prog'':= PTree.set extra_pc' - (Ibuiltin (EF_profiling 0%Z) nil BR_none ifnot) prog' in - (Pos.succ extra_pc', prog''). - -Definition inject_at (prog : code) (pc extra_pc : node) : node * code := - match PTree.get pc prog with - | Some (Icond cond args ifso ifnot expected) => - inject_profiling_call - (PTree.set pc - (Icond cond args extra_pc (Pos.succ extra_pc) expected) prog) +Parameter fundef_id : fundef -> Z. +Parameter branch_id : Z -> node -> Z. + +Section PER_FUNCTION_ID. + Variable function_id : Z. + + Definition inject_profiling_call (prog : code) + (pc extra_pc ifso ifnot : node) : node * code := + let id := branch_id function_id pc in + let extra_pc' := Pos.succ extra_pc in + let prog' := PTree.set extra_pc + (Ibuiltin (EF_profiling id 0%Z) nil BR_none ifso) prog in + let prog'':= PTree.set extra_pc' + (Ibuiltin (EF_profiling id 1%Z) nil BR_none ifnot) prog' in + (Pos.succ extra_pc', prog''). + + Definition inject_at (prog : code) (pc extra_pc : node) : node * code := + match PTree.get pc prog with + | Some (Icond cond args ifso ifnot expected) => + inject_profiling_call + (PTree.set pc + (Icond cond args extra_pc (Pos.succ extra_pc) expected) prog) pc extra_pc ifso ifnot - | _ => inject_profiling_call prog pc extra_pc 1 1 (* does not happen *) - end. - -Definition inject_at' (already : node * code) pc := - let (extra_pc, prog) := already in - inject_at prog pc extra_pc. - -Definition inject_l (prog : code) extra_pc injections := - List.fold_left (fun already (inject_pc : node) => - inject_at' already inject_pc) - injections - (extra_pc, prog). - -Definition gen_conditions (prog : code) := - List.map fst (PTree.elements (PTree.filter1 - (fun instr => - match instr with - | Icond cond args ifso ifnot expected => true - | _ => false - end) prog)). - -Definition transf_function (f : function) : function := - let max_pc := max_pc_function f in - let conditions := gen_conditions (fn_code f) in + | _ => inject_profiling_call prog pc extra_pc 1 1 (* does not happen *) + end. + + Definition inject_at' (already : node * code) pc := + let (extra_pc, prog) := already in + inject_at prog pc extra_pc. + + Definition inject_l (prog : code) extra_pc injections := + List.fold_left (fun already (inject_pc : node) => + inject_at' already inject_pc) + injections + (extra_pc, prog). + + Definition gen_conditions (prog : code) := + List.map fst (PTree.elements (PTree.filter1 + (fun instr => + match instr with + | Icond cond args ifso ifnot expected => true + | _ => false + end) prog)). + + Definition transf_function (f : function) : function := + let max_pc := max_pc_function f in + let conditions := gen_conditions (fn_code f) in {| fn_sig := f.(fn_sig); - fn_params := f.(fn_params); - fn_stacksize := f.(fn_stacksize); - fn_code := snd (inject_l (fn_code f) (Pos.succ max_pc) conditions); - fn_entrypoint := f.(fn_entrypoint) |}. + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := snd (inject_l (fn_code f) (Pos.succ max_pc) conditions); + fn_entrypoint := f.(fn_entrypoint) |}. + +End PER_FUNCTION_ID. Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef transf_function fd. + AST.transf_fundef (transf_function (fundef_id fd)) fd. Definition transf_program (p: program) : program := transform_program transf_fundef p. diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 609689a7..fbf9bbeb 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -535,7 +535,7 @@ Definition do_external (ef: external_function): | EF_annot_val kind text targ => do_ef_annot_val text targ | EF_inline_asm text sg clob => do_inline_assembly text sg ge | EF_debug kind text targs => do_ef_debug kind text targs - | EF_profiling id => do_ef_profiling id + | EF_profiling id kind => do_ef_profiling id end. Lemma do_ef_external_sound: diff --git a/common/AST.v b/common/AST.v index 595ace01..846678c2 100644 --- a/common/AST.v +++ b/common/AST.v @@ -466,6 +466,7 @@ Qed. (* Identifiers for profiling information *) Definition profiling_id := Z.t. +Definition profiling_kind := Z.t. (** For most languages, the functions composing the program are either internal functions, defined within the language, or external functions, @@ -521,8 +522,8 @@ Inductive external_function : Type := (** Transport debugging information from the front-end to the generated assembly. Takes zero, one or several arguments like [EF_annot]. Unlike [EF_annot], produces no observable event. *) - | EF_profiling (id: profiling_id). - (** Count one profiling event for this identifier. + | EF_profiling (id: profiling_id) (kind : profiling_kind). + (** Count one profiling event for this identifier and kind. Takes no argument. Produces no observable event. *) (** The type signature of an external function. *) @@ -541,7 +542,7 @@ Definition ef_sig (ef: external_function): signature := | EF_annot_val kind text targ => mksignature (targ :: nil) targ cc_default | EF_inline_asm text sg clob => sg | EF_debug kind text targs => mksignature targs Tvoid cc_default - | EF_profiling id => mksignature nil Tvoid cc_default + | EF_profiling id kind => mksignature nil Tvoid cc_default end. (** Whether an external function should be inlined by the compiler. *) @@ -560,7 +561,7 @@ Definition ef_inline (ef: external_function) : bool := | EF_annot_val kind Text rg => true | EF_inline_asm text sg clob => true | EF_debug kind text targs => true - | EF_profiling id => true + | EF_profiling id kind => true end. (** Whether an external function must reload its arguments. *) diff --git a/common/Events.v b/common/Events.v index 16efd89c..033e2e03 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1569,7 +1569,7 @@ Definition external_call (ef: external_function): extcall_sem := | EF_annot_val kind txt targ => extcall_annot_val_sem txt targ | EF_inline_asm txt sg clb => inline_assembly_sem txt sg | EF_debug kind txt targs => extcall_debug_sem - | EF_profiling id => extcall_profiling_sem + | EF_profiling id kind => extcall_profiling_sem end. Theorem external_call_spec: diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 7f15bc91..69939428 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -62,8 +62,8 @@ let name_of_external = function | EF_inline_asm(text, sg, clob) -> sprintf "inline_asm %S" (camlstring_of_coqstring text) | EF_debug(kind, text, targs) -> sprintf "debug%d %S" (P.to_int kind) (extern_atom text) - | EF_profiling(id) -> - sprintf "profiling %LX" (Z.to_int64 id) + | EF_profiling(id, kind) -> + sprintf "profiling %LX %d" (Z.to_int64 id) (Z.to_int kind) let rec print_builtin_arg px oc = function | BA x -> px oc x diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 6986fb96..87c8d9c8 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -82,3 +82,6 @@ let option_fcoalesce_mem = ref true let option_fforward_moves = ref true let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 + +let option_profile_arcs = ref false + diff --git a/driver/Compopts.v b/driver/Compopts.v index 848657e5..245322ef 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -75,6 +75,9 @@ Parameter all_loads_nontrap: unit -> bool. (** Flag -fforward-moves. Forward moves after CSE. *) Parameter optim_forward_moves: unit -> bool. +(** Flag -fprofile-arcs. Add profiling logger. *) +Parameter profile_arcs : unit -> bool. + (* TODO is there a more appropriate place? *) Require Import Coqlib. Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. diff --git a/driver/Driver.ml b/driver/Driver.ml index 388482a0..909ef0d5 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -223,6 +223,7 @@ Code generation options: (use -fno- to turn off -f) -falign-branch-targets Set alignment (in bytes) of branch targets -falign-cond-branches Set alignment (in bytes) of conditional branches -fcommon Put uninitialized globals in the common section [on]. + -fprofile-arcs Profile branches [off]. |} ^ target_help ^ toolchain_help ^ @@ -412,7 +413,8 @@ let cmdline_actions = @ f_opt "coalesce-mem" option_fcoalesce_mem @ f_opt "all-loads-nontrap" option_all_loads_nontrap @ f_opt "forward-moves" option_fforward_moves -(* Code generation options *) + (* Code generation options *) + @ f_opt "profile-arcs" option_profile_arcs @ f_opt "fpu" option_ffpu @ f_opt "sse" option_ffpu (* backward compatibility *) @ [ -- cgit From 3c30567c452f030267d0fb09465adf8d7b44a90d Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 12:36:24 +0200 Subject: installed Profiling (not finished) --- backend/Profiling.v | 23 +++-- backend/Profilingaux.ml | 8 ++ backend/Profilingproof.v | 227 +++++++++++++++++++++++++++++++++++++++++++++++ driver/Compiler.v | 33 ++++--- extraction/extraction.v | 7 +- 5 files changed, 273 insertions(+), 25 deletions(-) create mode 100644 backend/Profilingaux.ml create mode 100644 backend/Profilingproof.v diff --git a/backend/Profiling.v b/backend/Profiling.v index 4995c507..1840af6e 100644 --- a/backend/Profiling.v +++ b/backend/Profiling.v @@ -4,7 +4,7 @@ Require Import Memory Registers Op RTL. Local Open Scope positive. -Parameter fundef_id : fundef -> Z. +Parameter function_id : function -> Z. Parameter branch_id : Z -> node -> Z. Section PER_FUNCTION_ID. @@ -47,20 +47,19 @@ Section PER_FUNCTION_ID. | Icond cond args ifso ifnot expected => true | _ => false end) prog)). - - Definition transf_function (f : function) : function := - let max_pc := max_pc_function f in - let conditions := gen_conditions (fn_code f) in - {| fn_sig := f.(fn_sig); - fn_params := f.(fn_params); - fn_stacksize := f.(fn_stacksize); - fn_code := snd (inject_l (fn_code f) (Pos.succ max_pc) conditions); - fn_entrypoint := f.(fn_entrypoint) |}. - End PER_FUNCTION_ID. +Definition transf_function (f : function) : function := + let max_pc := max_pc_function f in + let conditions := gen_conditions (fn_code f) in + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := snd (inject_l (function_id f) (fn_code f) (Pos.succ max_pc) conditions); + fn_entrypoint := f.(fn_entrypoint) |}. + Definition transf_fundef (fd: fundef) : fundef := - AST.transf_fundef (transf_function (fundef_id fd)) fd. + AST.transf_fundef transf_function fd. Definition transf_program (p: program) : program := transform_program transf_fundef p. diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml new file mode 100644 index 00000000..ad963a48 --- /dev/null +++ b/backend/Profilingaux.ml @@ -0,0 +1,8 @@ +open Camlcoq +open RTL + +let function_id (f : coq_function) : Z.t = + Z.of_uint 0;; + +let branch_id (f_id : Z.t) (node : P.t) = + Z.of_uint 0;; diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v new file mode 100644 index 00000000..0e6171d6 --- /dev/null +++ b/backend/Profilingproof.v @@ -0,0 +1,227 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import Profiling. +Require Import Lia. + +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (Genv.find_funct_transf TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. +Proof. + destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + unfold find_function; intros. destruct ros as [r|id]. + eapply functions_translated; eauto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. +Qed. + +(* +Lemma transf_function_at: + forall hash f pc i, + f.(fn_code)!pc = Some i -> + (match i with + | Icond _ _ _ _ _ => False + | _ => True) -> + (transf_function hash f).(fn_code)!pc = Some i. +Proof. + intros until i. intro Hcode. + unfold transf_function; simpl. + destruct (peq pc (Pos.succ (max_pc_function f))) as [EQ | NEQ]. + { assert (pc <= (max_pc_function f))%positive as LE by (eapply max_pc_function_sound; eassumption). + subst pc. + lia. + } + rewrite PTree.gso by congruence. + assumption. +Qed. + *) + + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := +| match_frames_intro: forall res f sp pc rs, + match_frames (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). + +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (State stk f sp pc rs m) + (State stk' (transf_function f) sp pc rs m) + | match_callstates: forall stk f args m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Callstate stk f args m) + (Callstate stk' (transf_fundef f) args m) + | match_returnstates: forall stk v m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Returnstate stk v m) + (Returnstate stk' v m). + + +Lemma step_simulation: + forall s1 t s2 (STEP : step ge s1 t s2) + s1' (MS: match_states s1 s1'), + exists s2', plus step tge s1' t s2' /\ match_states s2 s2'. +Proof. + induction 1; intros; inv MS. +Admitted. + +(* + - left. econstructor. split. + + eapply plus_one. eapply exec_Inop; eauto with firstnop. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iop with (v:=v); eauto with firstnop. + rewrite <- H0. + apply eval_operation_preserved. + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload with (v:=v); eauto with firstnop. + all: rewrite <- H0. + all: auto using eval_addressing_preserved, symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload_notrap1; eauto with firstnop. + all: rewrite <- H0; + apply eval_addressing_preserved; + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Iload_notrap2; eauto with firstnop. + all: rewrite <- H0; + apply eval_addressing_preserved; + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Istore; eauto with firstnop. + all: rewrite <- H0; + apply eval_addressing_preserved; + apply symbols_preserved. + + constructor; auto with firstnop. + - left. econstructor. split. + + eapply plus_one. eapply exec_Icall. + apply match_pc_same. exact H. + apply find_function_translated. + exact H0. + apply sig_preserved. + + constructor. + constructor; auto. + constructor. + - left. econstructor. split. + + eapply plus_one. eapply exec_Itailcall. + apply match_pc_same. exact H. + apply find_function_translated. + exact H0. + apply sig_preserved. + unfold transf_function; simpl. + eassumption. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ibuiltin; eauto with firstnop. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Icond; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ijumptable; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_Ireturn; eauto with firstnop. + + constructor; auto. + - left. econstructor. split. + + eapply plus_two. + * eapply exec_function_internal; eauto with firstnop. + * eapply exec_Inop. + unfold transf_function; simpl. + rewrite PTree.gss. + reflexivity. + * auto. + + constructor; auto. + - left. econstructor. split. + + eapply plus_one. eapply exec_function_external; eauto with firstnop. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + constructor; auto. + - left. + inv STACKS. inv H1. + econstructor; split. + + eapply plus_one. eapply exec_return; eauto. + + constructor; auto. +Qed. + *) + +Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. +Proof. + intros. inv H. econstructor; split. + econstructor. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. + eapply function_ptr_translated; eauto. + rewrite <- H3; apply sig_preserved. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. +Proof. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + eapply forward_simulation_plus. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/driver/Compiler.v b/driver/Compiler.v index 499feff2..dc32cd3f 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -37,6 +37,7 @@ Require Selection. Require RTLgen. Require Tailcall. Require Inlining. +Require Profiling. Require Renumber. Require Duplicate. Require Constprop. @@ -62,6 +63,7 @@ Require Selectionproof. Require RTLgenproof. Require Tailcallproof. Require Inliningproof. +Require Profilingproof. Require Renumberproof. Require Duplicateproof. Require Constpropproof. @@ -132,26 +134,28 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 1) @@@ time "Inlining" Inlining.transf_program @@ print (print_RTL 2) - @@ time "Renumbering" Renumber.transf_program + @@ total_if Compopts.profile_arcs (time "Profiling insertion" Profiling.transf_program) @@ print (print_RTL 3) - @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) + @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 4) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) + @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) @@ print (print_RTL 5) - @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) + @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 6) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) + @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) @@ print (print_RTL 7) - @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) + @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 8) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program + @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 9) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 10) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 11) - @@@ time "Unused globals" Unusedglob.transform_program + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program @@ print (print_RTL 12) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 13) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -253,6 +257,7 @@ Definition CompCert's_passes := ::: mkpass RTLgenproof.match_prog ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog + ::: mkpass (match_if Compopts.profile_arcs Profilingproof.match_prog) ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) @@ -300,7 +305,8 @@ Proof. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. - set (p9 := Renumber.transf_program p8) in *. + set (p8bis := total_if profile_arcs Profiling.transf_program p8) in *. + set (p9 := Renumber.transf_program p8bis) in *. destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. @@ -325,6 +331,7 @@ Proof. exists p6; split. apply RTLgenproof.transf_program_match; auto. exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. exists p8; split. apply Inliningproof.transf_program_match; auto. + exists p8bis; split. apply total_if_match. apply Profilingproof.transf_program_match; auto. exists p9; split. apply Renumberproof.transf_program_match; auto. exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match. @@ -392,7 +399,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p25)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p26)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -410,6 +417,8 @@ Ltac DestructM := eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. eapply compose_forward_simulations. eapply Inliningproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Profilingproof.transf_program_correct. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. diff --git a/extraction/extraction.v b/extraction/extraction.v index 9b568951..c2b5d83e 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -137,6 +137,8 @@ Extract Constant Compopts.va_strict => "fun _ -> false". Extract Constant Compopts.all_loads_nontrap => "fun _ -> !Clflags.option_all_loads_nontrap". +Extract Constant Compopts.profile_arcs => + "fun _ -> !Clflags.option_profile_arcs". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". @@ -147,9 +149,12 @@ Extract Constant Compiler.print_Mach => "PrintMach.print_if". Extract Constant Compiler.print => "fun (f: 'a -> unit) (x: 'a) -> f x; x". Extract Constant Compiler.time => "Timing.time_coq". Extract Constant Compopts.time => "Timing.time_coq". - (*Extraction Inline Compiler.apply_total Compiler.apply_partial.*) +(* Profiling *) +Extract Constant Profiling.function_id => "Profilingaux.function_id". +Extract Constant Profiling.branch_id => "Profilingaux.branch_id". + (* Cabs *) Extract Constant Cabs.loc => "{ lineno : int; -- cgit From cce39d8408cfa33ae4cc7c586e35546a5b731dbf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 12:39:07 +0200 Subject: so that it gets printed --- mppa_k1c/TargetPrinter.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 930b1c51..491d2c14 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -328,6 +328,9 @@ module Target (*: TARGET*) = fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment + | EF_profiling(id, kind) -> + fprintf oc "%s profiling %LX %d\n" comment + (Z.to_int64 id) (Z.to_int kind) | _ -> assert false end -- cgit From d3a8a8870050810a7bc3fb5e004059197ec364f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 13:06:00 +0200 Subject: print hashes --- backend/Profiling.v | 8 ++++---- backend/Profilingaux.ml | 20 ++++++++++++++++---- common/AST.v | 5 +++-- common/PrintAST.ml | 2 +- extraction/extraction.v | 2 ++ mppa_k1c/TargetPrinter.ml | 4 ++-- 6 files changed, 28 insertions(+), 13 deletions(-) diff --git a/backend/Profiling.v b/backend/Profiling.v index 1840af6e..0dfc0a0b 100644 --- a/backend/Profiling.v +++ b/backend/Profiling.v @@ -4,15 +4,15 @@ Require Import Memory Registers Op RTL. Local Open Scope positive. -Parameter function_id : function -> Z. -Parameter branch_id : Z -> node -> Z. +Parameter function_id : function -> AST.profiling_id. +Parameter branch_id : AST.profiling_id -> node -> AST.profiling_id. Section PER_FUNCTION_ID. - Variable function_id : Z. + Variable f_id : AST.profiling_id. Definition inject_profiling_call (prog : code) (pc extra_pc ifso ifnot : node) : node * code := - let id := branch_id function_id pc in + let id := branch_id f_id pc in let extra_pc' := Pos.succ extra_pc in let prog' := PTree.set extra_pc (Ibuiltin (EF_profiling id 0%Z) nil BR_none ifso) prog in diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index ad963a48..d57a38be 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -1,8 +1,20 @@ open Camlcoq open RTL -let function_id (f : coq_function) : Z.t = - Z.of_uint 0;; +let function_id (f : coq_function) : Digest.t = + Digest.string (Marshal.to_string f []);; -let branch_id (f_id : Z.t) (node : P.t) = - Z.of_uint 0;; +let branch_id (f_id : Digest.t) (node : P.t) : Digest.t = + Digest.string (f_id ^ (Int64.to_string (P.to_int64 node)));; + +let pp_id channel (x : Digest.t) = + for i=0 to 15 do + Printf.fprintf channel "%02x" (Char.code (String.get x i)) + done + +let spp_id () (x : Digest.t) : string = + let s = ref "" in + for i=0 to 15 do + s := Printf.sprintf "%02x%s" (Char.code (String.get x i)) !s + done; + !s;; diff --git a/common/AST.v b/common/AST.v index 846678c2..268e13d5 100644 --- a/common/AST.v +++ b/common/AST.v @@ -465,7 +465,8 @@ Qed. (** * External functions *) (* Identifiers for profiling information *) -Definition profiling_id := Z.t. +Parameter profiling_id : Type. +Axiom profiling_id_eq : forall (x y : profiling_id), {x=y} + {x<>y}. Definition profiling_kind := Z.t. (** For most languages, the functions composing the program are either @@ -577,7 +578,7 @@ Definition ef_reloads (ef: external_function) : bool := Definition external_function_eq: forall (ef1 ef2: external_function), {ef1=ef2} + {ef1<>ef2}. Proof. - generalize ident_eq string_dec signature_eq chunk_eq typ_eq list_eq_dec zeq Int.eq_dec; intros. + generalize profiling_id_eq ident_eq string_dec signature_eq chunk_eq typ_eq list_eq_dec zeq Int.eq_dec; intros. decide equality. Defined. Global Opaque external_function_eq. diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 69939428..e24607ee 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -63,7 +63,7 @@ let name_of_external = function | EF_debug(kind, text, targs) -> sprintf "debug%d %S" (P.to_int kind) (extern_atom text) | EF_profiling(id, kind) -> - sprintf "profiling %LX %d" (Z.to_int64 id) (Z.to_int kind) + sprintf "profiling %a %d" Profilingaux.spp_id id (Z.to_int kind) let rec print_builtin_arg px oc = function | BA x -> px oc x diff --git a/extraction/extraction.v b/extraction/extraction.v index c2b5d83e..72c19385 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -152,6 +152,8 @@ Extract Constant Compopts.time => "Timing.time_coq". (*Extraction Inline Compiler.apply_total Compiler.apply_partial.*) (* Profiling *) +Extract Constant AST.profiling_id => "Digest.t". +Extract Constant AST.profiling_id_eq => "Digest.equal". Extract Constant Profiling.function_id => "Profilingaux.function_id". Extract Constant Profiling.branch_id => "Profilingaux.branch_id". diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 491d2c14..eb2d7a97 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -329,8 +329,8 @@ module Target (*: TARGET*) = print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment | EF_profiling(id, kind) -> - fprintf oc "%s profiling %LX %d\n" comment - (Z.to_int64 id) (Z.to_int kind) + fprintf oc "%s profiling %a %d\n" comment + Profilingaux.pp_id id (Z.to_int kind) | _ -> assert false end -- cgit From eda23b6777f4d247f0d4dafa738a882f2cf3cc9b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 14:30:32 +0200 Subject: looks like it works? --- mppa_k1c/Machregs.v | 1 + mppa_k1c/TargetPrinter.ml | 42 ++++++++++++++++++++++++++++++++++++++---- 2 files changed, 39 insertions(+), 4 deletions(-) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index 8098b5d1..cff1164c 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -171,6 +171,7 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := if Z.leb sz 15 then R62 :: R63 :: R61 :: nil else R62 :: R63 :: R61 :: R60 :: nil + | EF_profiling _ _ => R62 :: R63 ::nil | _ => nil end. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index eb2d7a97..a3e6e9b5 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -239,7 +239,31 @@ module Target (*: TARGET*) = (*let w oc = if Archi.ptr64 then output_string oc "w" *) -(* Offset part of a load or store *) + + (* Profiling *) + + let profiling_counter_table_name = ".compcert_profiling_counters" + let profiling_table : (Digest.t, int) Hashtbl.t = Hashtbl.create 1000;; + let next_profiling_position = ref 0;; + let profiling_position (x : Digest.t) : int = + match Hashtbl.find_opt profiling_table x with + | None -> let y = !next_profiling_position in + next_profiling_position := succ y; + Hashtbl.add profiling_table x y; + y + | Some y -> y;; + + + let print_profiling oc = + let nr_items = !next_profiling_position in + if nr_items > 0 + then + begin + fprintf oc " .lcomm %s, %d\n" + profiling_counter_table_name (nr_items * 16) + end;; + + (* Offset part of a load or store *) let offset oc n = ptrofs oc n @@ -328,9 +352,18 @@ module Target (*: TARGET*) = fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment - | EF_profiling(id, kind) -> + | EF_profiling(id, coq_kind) -> + let kind = Z.to_int coq_kind in + assert (kind >= 0); + assert (kind <= 1); fprintf oc "%s profiling %a %d\n" comment - Profilingaux.pp_id id (Z.to_int kind) + Profilingaux.pp_id id kind; + fprintf oc " make $r63 = %s\n" profiling_counter_table_name; + fprintf oc " make $r62 = 1\n"; + fprintf oc " ;;\n"; + fprintf oc " afaddd %d[$r63] = $r62\n" + (((profiling_position id)*2 + kind)*8); + fprintf oc " ;;\n" | _ -> assert false end @@ -792,8 +825,9 @@ module Target (*: TARGET*) = if !Clflags.option_g then begin section oc Section_text; end - + let print_epilogue oc = + print_profiling oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; -- cgit From c3013f81f3f56d400e4cf9ac3a7ad8bf91ce7e2f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 14:49:09 +0200 Subject: print profiling ids --- mppa_k1c/TargetPrinter.ml | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index a3e6e9b5..5b66cc26 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -243,6 +243,7 @@ module Target (*: TARGET*) = (* Profiling *) let profiling_counter_table_name = ".compcert_profiling_counters" + and profiling_id_table_name = ".compcert_profiling_ids" let profiling_table : (Digest.t, int) Hashtbl.t = Hashtbl.create 1000;; let next_profiling_position = ref 0;; let profiling_position (x : Digest.t) : int = @@ -253,14 +254,33 @@ module Target (*: TARGET*) = y | Some y -> y;; - + let profiling_ids () = + let nr_items = !next_profiling_position in + let ar = Array.make nr_items "" in + Hashtbl.iter + (fun x y -> ar.(y) <- x) + profiling_table; + ar;; + + let print_profiling_id oc id = + assert (String.length id = 16); + output_string oc " .byte"; + for i=0 to 15 do + fprintf oc " 0x%02x" (Char.code (String.get id i)); + if i < 15 then output_char oc ',' + done; + output_char oc '\n';; + let print_profiling oc = let nr_items = !next_profiling_position in if nr_items > 0 then begin - fprintf oc " .lcomm %s, %d\n" - profiling_counter_table_name (nr_items * 16) + fprintf oc " .lcomm %s, %d\n" + profiling_counter_table_name (nr_items * 16); + fprintf oc " .section .rodata\n"; + fprintf oc "%s:\n" profiling_id_table_name; + Array.iter (print_profiling_id oc) (profiling_ids ()) end;; (* Offset part of a load or store *) -- cgit From ba6453483f7c742a98cd6fcefe015018df1dfea7 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 8 Apr 2020 11:57:37 +0200 Subject: Duplicate: Common rtl_successors function --- backend/Duplicateaux.ml | 94 +++++++++++++++++-------------------------------- 1 file changed, 33 insertions(+), 61 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 98e2f325..b137e872 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,3 +1,9 @@ +(* Oracle for Duplicate pass. + * - Add static prediction information to Icond nodes + * - Performs tail duplication on interesting traces to form superblocks + * - (TODO: perform partial loop unrolling inside innermost loops) + *) + open RTL open Maps open Camlcoq @@ -6,6 +12,13 @@ let get_some = function | None -> failwith "Did not get some" | Some thing -> thing +let rtl_successors = function +| Itailcall _ | Ireturn _ -> [] +| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n) +| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n] +| Icond (_,_,n1,n2,_) -> [n1; n2] +| Ijumptable (_,ln) -> ln + let bfs code entrypoint = begin Printf.printf "bfs\n"; flush stdout; let visited = ref (PTree.map (fun n i -> false) code) @@ -22,13 +35,8 @@ let bfs code entrypoint = begin | None -> failwith "No such node" | Some i -> bfs_list := !node :: !bfs_list; - match i with - | Icall(_, _, _, _, n) -> Queue.add n to_visit - | Ibuiltin(_, _, _, n) -> Queue.add n to_visit - | Ijumptable(_, ln) -> List.iter (fun n -> Queue.add n to_visit) ln - | Itailcall _ | Ireturn _ -> () - | Icond (_, _, n1, n2, _) -> Queue.add n1 to_visit; Queue.add n2 to_visit - | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> Queue.add n to_visit + let succ = rtl_successors i in + List.iter (fun n -> Queue.add n to_visit) succ end done; List.rev !bfs_list @@ -43,12 +51,7 @@ let get_predecessors_rtl code = begin Printf.printf "get_predecessors_rtl\n"; flush stdout; let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, i) = - let succ = match i with - | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) - | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] - | Icond (_,_,n1,n2,_) -> [n1;n2] - | Ijumptable (_,ln) -> ln - | Itailcall _ | Ireturn _ -> [] + let succ = rtl_successors i in List.iter (fun s -> let previous_preds = ptree_get_some s !preds in if optbool @@ List.find_opt (fun e -> e == node) previous_preds then () @@ -113,13 +116,7 @@ let get_loop_headers code entrypoint = begin visited := PTree.set node Processed !visited; match PTree.get node code with | None -> failwith "No such node" - | Some i -> let next_visits = (match i with - | Icall (_, _, _, _, n) | Ibuiltin (_, _, _, n) | Inop n | Iop (_, _, _, n) - | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) -> [n] - | Icond (_, _, n1, n2, _) -> [n1; n2] - | Itailcall _ | Ireturn _ -> [] - | Ijumptable (_, ln) -> ln - ) in dfs_visit code next_visits; + | Some i -> let next_visits = rtl_successors i in dfs_visit code next_visits; visited := PTree.set node Visited !visited; dfs_visit code ln end @@ -143,16 +140,13 @@ let ptree_printbool pt = * the given predicate *) let rec look_ahead code node is_loop_header predicate = if (predicate node) then true - else match (get_some @@ PTree.get node code) with - | Ireturn _ | Itailcall _ | Icond _ | Ijumptable _ -> false - | Inop n | Iop (_, _, _, n) | Iload (_, _, _, _, _, n) - | Istore (_, _, _, _, n) | Icall (_, _, _, _, n) - | Ibuiltin (_, _, _, n) -> - if (predicate n) then true - else ( - if (get_some @@ PTree.get n is_loop_header) then false - else look_ahead code n is_loop_header predicate - ) + else match (rtl_successors @@ get_some @@ PTree.get node code) with + | [n] -> if (predicate n) then true + else ( + if (get_some @@ PTree.get n is_loop_header) then false + else look_ahead code n is_loop_header predicate + ) + | _ -> false let do_call_heuristic code cond ifso ifnot is_loop_header = begin @@ -233,11 +227,11 @@ let get_loop_info is_loop_header bfs_order code = else if src == dest then true else begin visited := PTree.set src true !visited; - match get_some @@ PTree.get src code with - | Inop s | Iop (_, _, _, s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) - | Ibuiltin (_,_,_,s) -> explore s dest - | Icond (_,_,s1,s2,_) -> (explore s1 dest) || (explore s2 dest) - | Ijumptable _ | Itailcall _ | Ireturn _ -> false + match rtl_successors @@ get_some @@ PTree.get src code with + | [] -> false + | [s] -> explore s dest + | [s1; s2] -> (explore s1 dest) || (explore s2 dest) + | _ -> false end in let rec advance_to_cb src = if (get_some @@ PTree.get src !visited) then None @@ -275,14 +269,14 @@ let get_loop_info is_loop_header bfs_order code = | Inop s | Iop (_,_,_,s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s) | Ibuiltin (_, _, _, s) -> if get_some @@ PTree.get s is_loop_header then mark_path s n - | Icond _ -> () (* loop backedges are never Icond in CompCert *) + | Icond _ -> () (* loop backedges are never Icond in CompCert RTL.3 *) | Ijumptable _ -> () | Itailcall _ | Ireturn _ -> () ) bfs_order; !loop_info end - (* Remark - compared to the original paper, we don't use the store heuristic *) +(* Remark - compared to the original paper, we don't use the store heuristic *) let get_directions code entrypoint = begin Printf.printf "get_directions\n"; flush stdout; let bfs_order = bfs code entrypoint in @@ -373,24 +367,6 @@ let dfs code entrypoint = begin in dfs_list code [entrypoint] end -(* -let get_predecessors_ttl code = - let preds = ref (PTree.map (fun n i -> []) code) in - let process_inst (node, ti) = match ti with - | Tleaf _ -> () - | Tnext (_, i) -> let succ = match i with - | Inop n | Iop (_,_,_,n) | Iload (_, _,_,_,_,n) | Istore (_,_,_,_,n) - | Icall (_,_,_,_,n) | Ibuiltin (_, _, _, n) -> [n] - | Icond (_,_,n1,n2,_) -> [n1;n2] - | Ijumptable (_,ln) -> ln - | _ -> [] - in List.iter (fun s -> preds := PTree.set s (node::(get_some @@ PTree.get s !preds)) !preds) succ - in begin - List.iter process_inst (PTree.elements code); - !preds - end -*) - let rec select_unvisited_node is_visited = function | [] -> failwith "Empty list" | n :: ln -> if not (ptree_get_some n is_visited) then n else select_unvisited_node is_visited ln @@ -400,12 +376,8 @@ let best_successor_of node code is_visited = | None -> failwith "No such node in the code" | Some i -> let next_node = match i with - | Inop n -> Some n - | Iop (_, _, _, n) -> Some n - | Iload (_, _, _, _, _, n) -> Some n - | Istore (_, _, _, _, n) -> Some n - | Icall (_, _, _, _, n) -> Some n - | Ibuiltin (_, _, _, n) -> Some n + | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore(_,_,_,_,n) + | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> Some n | Icond (_, _, n1, n2, ob) -> (match ob with None -> None | Some false -> Some n2 | Some true -> Some n1) | _ -> None in match next_node with -- cgit From e326ed9f28a2ed6869f0cb356ef9a8e189cb0a47 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 8 Apr 2020 14:53:50 +0200 Subject: Some cleaning on Linearize and Duplicate --- backend/Duplicateaux.ml | 124 +++++++++++++++++++++++++++--------------------- backend/Linearizeaux.ml | 89 ++++++++++++++++++---------------- 2 files changed, 118 insertions(+), 95 deletions(-) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index b137e872..89f187da 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -8,6 +8,12 @@ open RTL open Maps open Camlcoq +let debug_flag = ref false + +let debug fmt = + if !debug_flag then Printf.eprintf fmt + else Printf.ifprintf stderr fmt + let get_some = function | None -> failwith "Did not get some" | Some thing -> thing @@ -20,7 +26,7 @@ let rtl_successors = function | Ijumptable (_,ln) -> ln let bfs code entrypoint = begin - Printf.printf "bfs\n"; flush stdout; + debug "bfs\n"; let visited = ref (PTree.map (fun n i -> false) code) and bfs_list = ref [] and to_visit = Queue.create () @@ -48,7 +54,7 @@ let optbool o = match o with Some _ -> true | None -> false let ptree_get_some n ptree = get_some @@ PTree.get n ptree let get_predecessors_rtl code = begin - Printf.printf "get_predecessors_rtl\n"; flush stdout; + debug "get_predecessors_rtl\n"; let preds = ref (PTree.map (fun n i -> []) code) in let process_inst (node, i) = let succ = rtl_successors i @@ -74,19 +80,23 @@ let print_intlist l = | [] -> () | n::ln -> (Printf.printf "%d " (P.to_int n); f ln) in begin - Printf.printf "["; - f l; - Printf.printf "]" + if !debug_flag then begin + Printf.printf "["; + f l; + Printf.printf "]" + end end let print_intset s = let seq = PSet.to_seq s in begin - Printf.printf "{"; - Seq.iter (fun n -> - Printf.printf "%d " (P.to_int n) - ) seq; - Printf.printf "}" + if !debug_flag then begin + Printf.printf "{"; + Seq.iter (fun n -> + Printf.printf "%d " (P.to_int n) + ) seq; + Printf.printf "}" + end end type vstate = Unvisited | Processed | Visited @@ -99,7 +109,7 @@ type vstate = Unvisited | Processed | Visited * If we come accross an edge to a Processed node, it's a loop! *) let get_loop_headers code entrypoint = begin - Printf.printf "get_loop_headers\n"; flush stdout; + debug "get_loop_headers\n"; let visited = ref (PTree.map (fun n i -> Unvisited) code) and is_loop_header = ref (PTree.map (fun n i -> false) code) in let rec dfs_visit code = function @@ -108,7 +118,7 @@ let get_loop_headers code entrypoint = begin match (get_some @@ PTree.get node !visited) with | Visited -> () | Processed -> begin - Printf.printf "Node %d is a loop header\n" (P.to_int node); + debug "Node %d is a loop header\n" (P.to_int node); is_loop_header := PTree.set node true !is_loop_header; visited := PTree.set node Visited !visited end @@ -129,11 +139,13 @@ end let ptree_printbool pt = let elements = PTree.elements pt in begin - Printf.printf "["; - List.iter (fun (n, b) -> - if b then Printf.printf "%d, " (P.to_int n) else () - ) elements; - Printf.printf "]" + if !debug_flag then begin + Printf.printf "["; + List.iter (fun (n, b) -> + if b then Printf.printf "%d, " (P.to_int n) else () + ) elements; + Printf.printf "]" + end end (* Looks ahead (until a branch) to see if a node further down verifies @@ -150,7 +162,7 @@ let rec look_ahead code node is_loop_header predicate = let do_call_heuristic code cond ifso ifnot is_loop_header = begin - Printf.printf "\tCall heuristic..\n"; + debug "\tCall heuristic..\n"; let predicate n = (function | Icall _ -> true | _ -> false) @@ get_some @@ PTree.get n code @@ -164,13 +176,13 @@ let do_call_heuristic code cond ifso ifnot is_loop_header = let do_opcode_heuristic code cond ifso ifnot is_loop_header = begin - Printf.printf "\tOpcode heuristic..\n"; + debug "\tOpcode heuristic..\n"; DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header end let do_return_heuristic code cond ifso ifnot is_loop_header = begin - Printf.printf "\tReturn heuristic..\n"; + debug "\tReturn heuristic..\n"; let predicate n = (function | Ireturn _ -> true | _ -> false) @@ get_some @@ PTree.get n code @@ -184,7 +196,7 @@ let do_return_heuristic code cond ifso ifnot is_loop_header = let do_store_heuristic code cond ifso ifnot is_loop_header = begin - Printf.printf "\tStore heuristic..\n"; + debug "\tStore heuristic..\n"; let predicate n = (function | Istore _ -> true | _ -> false) @@ get_some @@ PTree.get n code @@ -198,7 +210,7 @@ let do_store_heuristic code cond ifso ifnot is_loop_header = let do_loop_heuristic code cond ifso ifnot is_loop_header = begin - Printf.printf "\tLoop heuristic..\n"; + debug "\tLoop heuristic..\n"; let predicate n = get_some @@ PTree.get n is_loop_header in let ifso_loop = look_ahead code ifso is_loop_header predicate in let ifnot_loop = look_ahead code ifnot is_loop_header predicate in @@ -210,7 +222,7 @@ let do_loop_heuristic code cond ifso ifnot is_loop_header = let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header = begin - Printf.printf "\tLoop2 heuristic..\n"; + debug "\tLoop2 heuristic..\n"; match get_some @@ PTree.get n loop_info with | None -> None | Some b -> Some b @@ -244,23 +256,23 @@ let get_loop_info is_loop_header bfs_order code = | Ijumptable _ | Itailcall _ | Ireturn _ -> None end in begin - Printf.printf "Marking path from %d to %d\n" (P.to_int n) (P.to_int s); + debug "Marking path from %d to %d\n" (P.to_int n) (P.to_int s); match advance_to_cb s with - | None -> (Printf.printf "Nothing found\n") - | Some s -> ( Printf.printf "Advancing to %d\n" (P.to_int s); + | None -> (debug "Nothing found\n") + | Some s -> ( debug "Advancing to %d\n" (P.to_int s); match get_some @@ PTree.get s !loop_info with | None | Some _ -> begin match get_some @@ PTree.get s code with | Icond (_, _, n1, n2, _) -> let b1 = explore n1 n in let b2 = explore n2 n in - if (b1 && b2) then (Printf.printf "both true\n") - else if b1 then (Printf.printf "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info) - else if b2 then (Printf.printf "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info) - else (Printf.printf "none true\n") - | _ -> ( Printf.printf "not an icond\n" ) + if (b1 && b2) then (debug "both true\n") + else if b1 then (debug "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info) + else if b2 then (debug "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info) + else (debug "none true\n") + | _ -> ( debug "not an icond\n" ) end - (* | Some _ -> ( Printf.printf "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *) + (* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *) ) end in begin @@ -278,34 +290,34 @@ let get_loop_info is_loop_header bfs_order code = (* Remark - compared to the original paper, we don't use the store heuristic *) let get_directions code entrypoint = begin - Printf.printf "get_directions\n"; flush stdout; + debug "get_directions\n"; let bfs_order = bfs code entrypoint in let is_loop_header = get_loop_headers code entrypoint in let loop_info = get_loop_info is_loop_header bfs_order code in let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *) begin (* ptree_printbool is_loop_header; *) - (* Printf.printf "\n"; *) + (* debug "\n"; *) List.iter (fun n -> match (get_some @@ PTree.get n code) with | Icond (cond, lr, ifso, ifnot, _) -> - (* Printf.printf "Analyzing %d.." (P.to_int n); *) + (* debug "Analyzing %d.." (P.to_int n); *) let heuristics = [ do_opcode_heuristic; do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic; (* do_store_heuristic *) ] in let preferred = ref None in begin - Printf.printf "Deciding condition for RTL node %d\n" (P.to_int n); + debug "Deciding condition for RTL node %d\n" (P.to_int n); List.iter (fun do_heur -> match !preferred with | None -> preferred := do_heur code cond ifso ifnot is_loop_header | Some _ -> () ) heuristics; directions := PTree.set n !preferred !directions; - (match !preferred with | Some false -> Printf.printf "\tFALLTHROUGH\n" - | Some true -> Printf.printf "\tBRANCH\n" - | None -> Printf.printf "\tUNSURE\n"); - Printf.printf "---------------------------------------\n" + (match !preferred with | Some false -> debug "\tFALLTHROUGH\n" + | Some true -> debug "\tBRANCH\n" + | None -> debug "\tUNSURE\n"); + debug "---------------------------------------\n" end | _ -> () ) bfs_order; @@ -325,12 +337,12 @@ let rec update_direction_rec directions = function (* Uses branch prediction to write prediction annotations in Icond *) let update_directions code entrypoint = begin - Printf.printf "Update_directions\n"; flush stdout; + debug "Update_directions\n"; let directions = get_directions code entrypoint in begin - (* Printf.printf "Ifso directions: "; + (* debug "Ifso directions: "; ptree_printbool directions; - Printf.printf "\n"; *) + debug "\n"; *) update_direction_rec directions (PTree.elements code) end end @@ -345,7 +357,7 @@ let exists_false boolmap = exists_false_rec (PTree.elements boolmap) (* DFS using prediction info to guide the exploration *) let dfs code entrypoint = begin - Printf.printf "dfs\n"; flush stdout; + debug "dfs\n"; let visited = ref (PTree.map (fun n i -> false) code) in let rec dfs_list code = function | [] -> [] @@ -409,9 +421,11 @@ let print_traces traces = | [] -> () | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt in begin - Printf.printf "Traces: {"; - f traces; - Printf.printf "}\n"; + if !debug_flag then begin + Printf.printf "Traces: {"; + f traces; + Printf.printf "}\n"; + end end (* Dumb (but linear) trace selection *) @@ -447,12 +461,12 @@ let select_traces_linear code entrypoint = (* Algorithm mostly inspired from Chang and Hwu 1988 * "Trace Selection for Compiling Large C Application Programs to Microcode" *) let select_traces_chang code entrypoint = begin - Printf.printf "select_traces\n"; flush stdout; + debug "select_traces\n"; let order = dfs code entrypoint in let predecessors = get_predecessors_rtl code in let traces = ref [] in let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *) - Printf.printf "Length: %d\n" (List.length order); flush stdout; + debug "Length: %d\n" (List.length order); while exists_false !is_visited do (* while (there are unvisited nodes) *) let seed = select_unvisited_node !is_visited order in let trace = ref [seed] in @@ -485,8 +499,8 @@ let select_traces_chang code entrypoint = begin end end done; - (* Printf.printf "DFS: \t"; print_intlist order; Printf.printf "\n"; *) - Printf.printf "Traces: "; print_traces !traces; + (* debug "DFS: \t"; print_intlist order; debug "\n"; *) + debug "Traces: "; print_traces !traces; !traces end end @@ -528,7 +542,7 @@ let rec change_pointers code n n' = function * n': the integer which should contain the duplicate of n * returns: new code, new ptree *) let duplicate code ptree parent n preds n' = - Printf.printf "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n'); + debug "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n'); match PTree.get n' code with | Some _ -> failwith "The PTree already has a node n'" | None -> @@ -593,8 +607,8 @@ let superblockify_traces code preds traces = | trace :: traces -> let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace in if (nb_duplicated < max_nb_duplicated) - then (Printf.printf "End duplication\n"; f new_code new_ptree traces) - else (Printf.printf "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) + then (debug "End duplication\n"; f new_code new_ptree traces) + else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0)) in let new_code, new_ptree, _ = f code ptree traces in (new_code, new_ptree) @@ -604,7 +618,7 @@ let rec invert_iconds_trace code = function let code' = match ptree_get_some n code with | Icond (c, lr, ifso, ifnot, info) -> (match info with | Some true -> begin - (* Printf.printf "Reversing ifso/ifnot for node %d\n" (P.to_int n); *) + (* debug "Reversing ifso/ifnot for node %d\n" (P.to_int n); *) PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, Some false)) code end | _ -> code) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index bfa056ca..1381877b 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -13,6 +13,12 @@ open LTL open Maps +let debug_flag = ref false + +let debug fmt = + if !debug_flag then Printf.eprintf fmt + else Printf.ifprintf stderr fmt + (* Trivial enumeration, in decreasing order of PC *) (*** @@ -115,18 +121,11 @@ let enumerate_aux_flat f reach = flatten_blocks (basic_blocks f (join_points f)) (** - * Enumeration based on traces as identified by Duplicate.v - * - * The Duplicate phase heuristically identifies the most frequented paths. Each - * Icond is modified so that the preferred condition is a fallthrough (ifnot) - * rather than a branch (ifso). + * Alternate enumeration based on traces as identified by Duplicate.v * - * The enumeration below takes advantage of this - preferring to layout nodes - * following the fallthroughs of the Lcond branches. - * - * It is slightly adapted from the work of Petris and Hansen 90 on intraprocedural - * code positioning - only we do it on a broader grain, since we don't have the exact - * frequencies (we only know which branch is the preferred one) + * This is a slight alteration to the above heuristic, ensuring that any + * superblock will be contiguous in memory, while still following the original + * heuristic *) let get_some = function @@ -145,9 +144,11 @@ let print_plist l = | [] -> () | n :: l -> Printf.printf "%d, " (P.to_int n); f l in begin - Printf.printf "["; - f l; - Printf.printf "]" + if !debug_flag then begin + Printf.printf "["; + f l; + Printf.printf "]" + end end (* adapted from the above join_points function, but with PTree *) @@ -173,7 +174,7 @@ let forward_sequences code entry = let join_points = get_join_points code entry in (* returns the list of traversed nodes, and a list of nodes to start traversing next *) let rec traverse_fallthrough code node = - (* Printf.printf "Traversing %d..\n" (P.to_int node); *) + (* debug "Traversing %d..\n" (P.to_int node); *) if not (get_some @@ PTree.get node !visited) then begin visited := PTree.set node true !visited; match PTree.get node code with @@ -182,19 +183,19 @@ let forward_sequences code entry = let ln, rem = match (last_element bb) with | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _ | Lbuiltin _ -> assert false - | Ltailcall _ | Lreturn -> begin (* Printf.printf "STOP tailcall/return\n"; *) ([], []) end + | Ltailcall _ | Lreturn -> begin (* debug "STOP tailcall/return\n"; *) ([], []) end | Lbranch n -> if get_some @@ PTree.get n join_points then ([], [n]) else let ln, rem = traverse_fallthrough code n in (ln, rem) | Lcond (_, _, ifso, ifnot, info) -> (match info with - | None -> begin (* Printf.printf "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end + | None -> begin (* debug "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end | Some false -> if get_some @@ PTree.get ifnot join_points then ([], [ifso; ifnot]) else let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) | Some true -> let errstr = Printf.sprintf ("Inconsistency detected in node %d: ifnot is not the preferred branch") (P.to_int node) in failwith errstr) - | Ljumptable(_, ln) -> begin (* Printf.printf "STOP Ljumptable\n"; *) ([], ln) end + | Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end in ([node] @ ln, rem) end else ([], []) @@ -355,15 +356,19 @@ end module ISet = Set.Make(Int) let print_iset s = begin - Printf.printf "{"; - ISet.iter (fun e -> Printf.printf "%d, " e) s; - Printf.printf "}" + if !debug_flag then begin + Printf.printf "{"; + ISet.iter (fun e -> Printf.printf "%d, " e) s; + Printf.printf "}" + end end let print_depmap dm = begin - Printf.printf "[|"; - Array.iter (fun s -> print_iset s; Printf.printf ", ") dm; - Printf.printf "|]\n" + if !debug_flag then begin + Printf.printf "[|"; + Array.iter (fun s -> print_iset s; Printf.printf ", ") dm; + Printf.printf "|]\n" + end end let construct_depmap code entry fs = @@ -381,7 +386,7 @@ let construct_depmap code entry fs = !index end in let check_and_update_depmap from target = - (* Printf.printf "From %d to %d\n" (P.to_int from) (P.to_int target); *) + (* debug "From %d to %d\n" (P.to_int from) (P.to_int target); *) if not (ppmap_is_true (from, target) is_loop_edge) then let in_index_fs = find_index_of_node from in let out_index_fs = find_index_of_node target in @@ -423,14 +428,18 @@ let construct_depmap code entry fs = end let print_sequence s = - Printf.printf "["; - List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s; - Printf.printf "]\n" + if !debug_flag then begin + Printf.printf "["; + List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s; + Printf.printf "]\n" + end let print_ssequence ofs = - Printf.printf "["; - List.iter (fun s -> print_sequence s) ofs; - Printf.printf "]\n" + if !debug_flag then begin + Printf.printf "["; + List.iter (fun s -> print_sequence s) ofs; + Printf.printf "]\n" + end let order_sequences code entry fs = let fs_a = Array.of_list fs in @@ -442,13 +451,13 @@ let order_sequences code entry fs = assert (not fs_evaluated.(s_id)); ordered_fs := fs_a.(s_id) :: !ordered_fs; fs_evaluated.(s_id) <- true; - (* Printf.printf "++++++\n"; - Printf.printf "Scheduling %d\n" s_id; - Printf.printf "Initial depmap: "; print_depmap depmap; *) + (* debug "++++++\n"; + debug "Scheduling %d\n" s_id; + debug "Initial depmap: "; print_depmap depmap; *) Array.iteri (fun i deps -> depmap.(i) <- ISet.remove s_id deps ) depmap; - (* Printf.printf "Final depmap: "; print_depmap depmap; *) + (* debug "Final depmap: "; print_depmap depmap; *) end in let choose_best_of candidates = let current_best_id = ref None in @@ -478,7 +487,7 @@ let order_sequences code entry fs = begin Array.iteri (fun i deps -> begin - (* Printf.printf "Deps of %d: " i; print_iset deps; Printf.printf "\n"; *) + (* debug "Deps of %d: " i; print_iset deps; debug "\n"; *) (* FIXME - if we keep it that way (no dependency check), remove all the unneeded stuff *) if ((* deps == ISet.empty && *) not fs_evaluated.(i)) then candidates := i :: !candidates @@ -492,14 +501,14 @@ let order_sequences code entry fs = get_some (choose_best_of !candidates) end in begin - Printf.printf "-------------------------------\n"; - Printf.printf "depmap: "; print_depmap depmap; - Printf.printf "forward sequences identified: "; print_ssequence fs; + debug "-------------------------------\n"; + debug "depmap: "; print_depmap depmap; + debug "forward sequences identified: "; print_ssequence fs; while List.length !ordered_fs != List.length fs do let next_id = select_next () in evaluate next_id done; - Printf.printf "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); + debug "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs)); List.rev (!ordered_fs) end -- cgit From da923568ad5085654b8db034310c4db50848e16e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 15:45:05 +0200 Subject: library support for writing profiling information to files --- mppa_k1c/TargetPrinter.ml | 21 ++++++++++++++---- runtime/Makefile | 2 ++ runtime/c/write_profiling_table.c | 46 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 4 deletions(-) create mode 100644 runtime/c/write_profiling_table.c diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 5b66cc26..19537bc0 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -241,9 +241,7 @@ module Target (*: TARGET*) = *) (* Profiling *) - - let profiling_counter_table_name = ".compcert_profiling_counters" - and profiling_id_table_name = ".compcert_profiling_ids" + let profiling_table : (Digest.t, int) Hashtbl.t = Hashtbl.create 1000;; let next_profiling_position = ref 0;; let profiling_position (x : Digest.t) : int = @@ -270,6 +268,11 @@ module Target (*: TARGET*) = if i < 15 then output_char oc ',' done; output_char oc '\n';; + + let profiling_counter_table_name = ".compcert_profiling_counters" + and profiling_id_table_name = ".compcert_profiling_ids" + and profiling_write_table = ".compcert_profiling_write_table" + and profiling_write_table_helper = "_compcert_write_profiling_table";; let print_profiling oc = let nr_items = !next_profiling_position in @@ -280,7 +283,17 @@ module Target (*: TARGET*) = profiling_counter_table_name (nr_items * 16); fprintf oc " .section .rodata\n"; fprintf oc "%s:\n" profiling_id_table_name; - Array.iter (print_profiling_id oc) (profiling_ids ()) + Array.iter (print_profiling_id oc) (profiling_ids ()); + fprintf oc " .text\n"; + fprintf oc "%s:\n" profiling_write_table; + fprintf oc " make $r0 = %d\n" nr_items; + fprintf oc " make $r1 = %s\n" profiling_id_table_name; + fprintf oc " make $r2 = %s\n" profiling_counter_table_name; + fprintf oc " goto %s\n" profiling_write_table_helper; + fprintf oc " ;;\n"; + fprintf oc " .section .dtors.65435,\"aw\",@progbits\n"; + fprintf oc " .align 8\n"; + fprintf oc " .8byte %s\n" profiling_write_table end;; (* Offset part of a load or store *) diff --git a/runtime/Makefile b/runtime/Makefile index 3b1cabc4..c9883577 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -38,6 +38,8 @@ OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \ vararg.o endif +OBJS+=write_profiling_table.o + LIB=libcompcert.a INCLUDES=include/float.h include/stdarg.h include/stdbool.h \ diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c new file mode 100644 index 00000000..54044016 --- /dev/null +++ b/runtime/c/write_profiling_table.c @@ -0,0 +1,46 @@ +#include +#include +#include + +typedef uint8_t md5_hash[16]; +typedef uint64_t condition_counters[2]; + +static void write_id(FILE *fp, md5_hash *hash) { + fwrite(hash, 16, 1, fp); +} + +#define BYTE(counter, i) ((counter >> (8*i)) & 0xFF) +static void write_counter(FILE *fp, uint64_t counter) { + putc(BYTE(counter, 0), fp); + putc(BYTE(counter, 1), fp); + putc(BYTE(counter, 2), fp); + putc(BYTE(counter, 3), fp); + putc(BYTE(counter, 4), fp); + putc(BYTE(counter, 5), fp); + putc(BYTE(counter, 6), fp); + putc(BYTE(counter, 8), fp); +} + +void _compcert_write_profiling_table(unsigned int nr_items, + md5_hash id_table[], + condition_counters counter_table[]) { + errno = 0; + + FILE *fp = fopen("compcert_profiling.dat", "a"); + if (fp == NULL) { + perror("open CompCert profiling data for writing"); + return; + } + + for(unsigned int i=0; i Date: Wed, 8 Apr 2020 16:28:00 +0200 Subject: fixed a bug in support libraries; reload profiling info --- backend/Profilingaux.ml | 44 ++++++++++++++++++++++++++++++++++----- driver/Clflags.ml | 1 - driver/Driver.ml | 1 + mppa_k1c/TargetPrinter.ml | 2 +- runtime/c/write_profiling_table.c | 2 +- 5 files changed, 42 insertions(+), 8 deletions(-) diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index d57a38be..0644e843 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -1,20 +1,54 @@ open Camlcoq open RTL - -let function_id (f : coq_function) : Digest.t = + +type identifier = Digest.t + +let function_id (f : coq_function) : identifier = Digest.string (Marshal.to_string f []);; -let branch_id (f_id : Digest.t) (node : P.t) : Digest.t = +let branch_id (f_id : identifier) (node : P.t) : identifier = Digest.string (f_id ^ (Int64.to_string (P.to_int64 node)));; -let pp_id channel (x : Digest.t) = +let pp_id channel (x : identifier) = for i=0 to 15 do Printf.fprintf channel "%02x" (Char.code (String.get x i)) done -let spp_id () (x : Digest.t) : string = +let spp_id () (x : identifier) : string = let s = ref "" in for i=0 to 15 do s := Printf.sprintf "%02x%s" (Char.code (String.get x i)) !s done; !s;; + +let profiling_counts : (identifier, (Int64.t*Int64.t)) Hashtbl.t = Hashtbl.create 1000;; + +let get_counts id = + match Hashtbl.find_opt profiling_counts id with + | Some x -> x + | None -> (0L, 0L);; + +let add_profiling_counts id counter0 counter1 = + let (old0, old1) = get_counts id in + Hashtbl.replace profiling_counts id (Int64.add old0 counter0, + Int64.add old1 counter1);; + +let input_counter (ic : in_channel) : Int64.t = + let r = ref Int64.zero in + for i=0 to 7 + do + r := Int64.add !r (Int64.shift_left (Int64.of_int (input_byte ic)) (8*i)) + done; + !r;; + +let load_profiling_info (filename : string) : unit = + let ic = open_in filename in + try + while true do + let id : identifier = really_input_string ic 16 in + let counter0 = input_counter ic in + let counter1 = input_counter ic in + Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id counter0 counter1; + add_profiling_counts id counter0 counter1 + done + with End_of_file -> close_in ic;; diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 87c8d9c8..600c3371 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -84,4 +84,3 @@ let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 let option_profile_arcs = ref false - diff --git a/driver/Driver.ml b/driver/Driver.ml index 909ef0d5..7fbcb025 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -328,6 +328,7 @@ let cmdline_actions = _Regexp "-O[123]$", Unit (set_all optimization_options); Exact "-Os", Set option_Osize; Exact "-Obranchless", Set option_Obranchless; + Exact "-fprofile-use=", String (fun s -> Profilingaux.load_profiling_info s); Exact "-finline-auto-threshold", Integer (fun n -> option_inline_auto_threshold := n); Exact "-fsmall-data", Integer(fun n -> option_small_data := n); Exact "-fsmall-const", Integer(fun n -> option_small_const := n); diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 19537bc0..355696de 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -248,7 +248,7 @@ module Target (*: TARGET*) = match Hashtbl.find_opt profiling_table x with | None -> let y = !next_profiling_position in next_profiling_position := succ y; - Hashtbl.add profiling_table x y; + Hashtbl.replace profiling_table x y; y | Some y -> y;; diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 54044016..5c55c4b6 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -18,7 +18,7 @@ static void write_counter(FILE *fp, uint64_t counter) { putc(BYTE(counter, 4), fp); putc(BYTE(counter, 5), fp); putc(BYTE(counter, 6), fp); - putc(BYTE(counter, 8), fp); + putc(BYTE(counter, 7), fp); } void _compcert_write_profiling_table(unsigned int nr_items, -- cgit From c3f5f3dbd088091e3fab9f357b01693932d148f8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 17:02:45 +0200 Subject: reloading and exploiting seems to work --- Makefile | 1 + backend/ProfilingExploit.v | 30 ++++++++++++++++++++++++++++++ backend/Profilingaux.ml | 8 +++++++- driver/Clflags.ml | 1 + driver/Compiler.v | 33 +++++++++++++++++++++------------ driver/Compopts.v | 3 +++ driver/Driver.ml | 4 +++- extraction/extraction.v | 7 ++++++- 8 files changed, 72 insertions(+), 15 deletions(-) create mode 100644 backend/ProfilingExploit.v diff --git a/Makefile b/Makefile index cad61d9d..5acaee19 100644 --- a/Makefile +++ b/Makefile @@ -80,6 +80,7 @@ BACKEND=\ Tailcall.v Tailcallproof.v \ Inlining.v Inliningspec.v Inliningproof.v \ Profiling.v Profilingproof.v \ + ProfilingExploit.v ProfilingExploitproof.v \ Renumber.v Renumberproof.v \ Duplicate.v Duplicateproof.v \ RTLtyping.v \ diff --git a/backend/ProfilingExploit.v b/backend/ProfilingExploit.v new file mode 100644 index 00000000..cfca1a12 --- /dev/null +++ b/backend/ProfilingExploit.v @@ -0,0 +1,30 @@ +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. + +Local Open Scope positive. + +Parameter function_id : function -> AST.profiling_id. +Parameter branch_id : AST.profiling_id -> node -> AST.profiling_id. +Parameter condition_oracle : AST.profiling_id -> option bool. + +Definition transf_instr (f_id : AST.profiling_id) + (pc : node) (i : instruction) : instruction := + match i with + | Icond cond args ifso ifnot None => + Icond cond args ifso ifnot (condition_oracle (branch_id f_id pc)) + | _ => i + end. + +Definition transf_function (f : function) : function := + {| fn_sig := f.(fn_sig); + fn_params := f.(fn_params); + fn_stacksize := f.(fn_stacksize); + fn_code := PTree.map (transf_instr (function_id f)) f.(fn_code); + fn_entrypoint := f.(fn_entrypoint) |}. + +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index 0644e843..51718303 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -48,7 +48,13 @@ let load_profiling_info (filename : string) : unit = let id : identifier = really_input_string ic 16 in let counter0 = input_counter ic in let counter1 = input_counter ic in - Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id counter0 counter1; + (* Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id counter0 counter1; *) add_profiling_counts id counter0 counter1 done with End_of_file -> close_in ic;; + +let condition_oracle (id : identifier) : bool option = + let (count0, count1) = get_counts id in + Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1; + if count0 = count1 then None + else Some(count1 > count0);; diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 600c3371..e8f7cef2 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -84,3 +84,4 @@ let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 let option_profile_arcs = ref false +let option_fbranch_probabilities = ref true diff --git a/driver/Compiler.v b/driver/Compiler.v index dc32cd3f..3f0ac3e5 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -38,6 +38,7 @@ Require RTLgen. Require Tailcall. Require Inlining. Require Profiling. +Require ProfilingExploit. Require Renumber. Require Duplicate. Require Constprop. @@ -64,6 +65,7 @@ Require RTLgenproof. Require Tailcallproof. Require Inliningproof. Require Profilingproof. +Require ProfilingExploitproof. Require Renumberproof. Require Duplicateproof. Require Constpropproof. @@ -136,26 +138,28 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := @@ print (print_RTL 2) @@ total_if Compopts.profile_arcs (time "Profiling insertion" Profiling.transf_program) @@ print (print_RTL 3) - @@ time "Renumbering" Renumber.transf_program + @@ total_if Compopts.branch_probabilities (time "Profiling use" ProfilingExploit.transf_program) @@ print (print_RTL 4) - @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) + @@ time "Renumbering" Renumber.transf_program @@ print (print_RTL 5) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) + @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) @@ print (print_RTL 6) - @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) + @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) @@ print (print_RTL 7) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) + @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program) @@ print (print_RTL 8) - @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) + @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) @@ print (print_RTL 9) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program + @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) @@ print (print_RTL 10) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) + @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program @@ print (print_RTL 11) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program + @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) @@ print (print_RTL 12) - @@@ time "Unused globals" Unusedglob.transform_program + @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program @@ print (print_RTL 13) + @@@ time "Unused globals" Unusedglob.transform_program + @@ print (print_RTL 14) @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -258,6 +262,7 @@ Definition CompCert's_passes := ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) ::: mkpass Inliningproof.match_prog ::: mkpass (match_if Compopts.profile_arcs Profilingproof.match_prog) + ::: mkpass (match_if Compopts.branch_probabilities ProfilingExploitproof.match_prog) ::: mkpass Renumberproof.match_prog ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) @@ -306,7 +311,8 @@ Proof. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. set (p8bis := total_if profile_arcs Profiling.transf_program p8) in *. - set (p9 := Renumber.transf_program p8bis) in *. + set (p8ter := total_if branch_probabilities ProfilingExploit.transf_program p8bis) in *. + set (p9 := Renumber.transf_program p8ter) in *. destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. @@ -332,6 +338,7 @@ Proof. exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. exists p8; split. apply Inliningproof.transf_program_match; auto. exists p8bis; split. apply total_if_match. apply Profilingproof.transf_program_match; auto. + exists p8ter; split. apply total_if_match. apply ProfilingExploitproof.transf_program_match; auto. exists p9; split. apply Renumberproof.transf_program_match; auto. exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match. @@ -399,7 +406,7 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p26)). + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p27)). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -419,6 +426,8 @@ Ltac DestructM := eapply Inliningproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Profilingproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact ProfilingExploitproof.transf_program_correct. eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. diff --git a/driver/Compopts.v b/driver/Compopts.v index 245322ef..98cbcc37 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -78,6 +78,9 @@ Parameter optim_forward_moves: unit -> bool. (** Flag -fprofile-arcs. Add profiling logger. *) Parameter profile_arcs : unit -> bool. +(** Flag -fbranch_probabilities. Use profiling information if available *) +Parameter branch_probabilities : unit -> bool. + (* TODO is there a more appropriate place? *) Require Import Coqlib. Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. diff --git a/driver/Driver.ml b/driver/Driver.ml index 7fbcb025..29fbaa7c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -222,8 +222,10 @@ Code generation options: (use -fno- to turn off -f) -falign-functions Set alignment (in bytes) of function entry points -falign-branch-targets Set alignment (in bytes) of branch targets -falign-cond-branches Set alignment (in bytes) of conditional branches - -fcommon Put uninitialized globals in the common section [on]. + -fcommon Put uninitialized globals in the common section [on] -fprofile-arcs Profile branches [off]. + -fprofile-use= filename Use profiling information in filename + -fbranch-probabilities Use profiling information (if available) for branches [on] |} ^ target_help ^ toolchain_help ^ diff --git a/extraction/extraction.v b/extraction/extraction.v index 72c19385..eb811f6c 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -138,7 +138,9 @@ Extract Constant Compopts.va_strict => Extract Constant Compopts.all_loads_nontrap => "fun _ -> !Clflags.option_all_loads_nontrap". Extract Constant Compopts.profile_arcs => - "fun _ -> !Clflags.option_profile_arcs". +"fun _ -> !Clflags.option_profile_arcs". +Extract Constant Compopts.branch_probabilities => + "fun _ -> !Clflags.option_fbranch_probabilities". (* Compiler *) Extract Constant Compiler.print_Clight => "PrintClight.print_if". @@ -156,6 +158,9 @@ Extract Constant AST.profiling_id => "Digest.t". Extract Constant AST.profiling_id_eq => "Digest.equal". Extract Constant Profiling.function_id => "Profilingaux.function_id". Extract Constant Profiling.branch_id => "Profilingaux.branch_id". +Extract Constant ProfilingExploit.function_id => "Profilingaux.function_id". +Extract Constant ProfilingExploit.branch_id => "Profilingaux.branch_id". +Extract Constant ProfilingExploit.condition_oracle => "Profilingaux.condition_oracle". (* Cabs *) Extract Constant Cabs.loc => -- cgit From 7aca3fcf600365b416865a6b6bc6ecc9852b08df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 17:24:09 +0200 Subject: -fbranch-probabilities --- driver/Driver.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/driver/Driver.ml b/driver/Driver.ml index 29fbaa7c..0f716168 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -417,7 +417,8 @@ let cmdline_actions = @ f_opt "all-loads-nontrap" option_all_loads_nontrap @ f_opt "forward-moves" option_fforward_moves (* Code generation options *) - @ f_opt "profile-arcs" option_profile_arcs + @ f_opt "profile-arcs" option_profile_arcs + @ f_opt "branch-probabilities" option_fbranch_probabilities @ f_opt "fpu" option_ffpu @ f_opt "sse" option_ffpu (* backward compatibility *) @ [ -- cgit From b58e5d1ae25b3b5b8a7d6124ff171777c298a1d2 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 17:30:48 +0200 Subject: test file for expect --- test/monniaux/expect/expect.c | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test/monniaux/expect/expect.c diff --git a/test/monniaux/expect/expect.c b/test/monniaux/expect/expect.c new file mode 100644 index 00000000..30e0742a --- /dev/null +++ b/test/monniaux/expect/expect.c @@ -0,0 +1,7 @@ +#ifndef PREDICTED +#define PREDICTED 0 +#endif + +int expect(int x, int *y, int *z) { + return __builtin_expect(x, PREDICTED) ? *y : *z; +} -- cgit From eea3055f57c77ce85a233f80e0d66b10c2564457 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 18:20:23 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 79 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 78 insertions(+), 1 deletion(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 0e6171d6..ad90eb7d 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -5,6 +5,8 @@ Require Import Registers Op RTL. Require Import Profiling. Require Import Lia. +Local Open Scope positive. + Definition match_prog (p tp: RTL.program) := match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. @@ -59,6 +61,82 @@ Proof. eapply function_ptr_translated; eauto. Qed. +Lemma pair_expand: + forall { A B : Type } (p : A*B), + p = ((fst p), (snd p)). +Proof. + destruct p; simpl; trivial. +Qed. + +Lemma inject_profiling_call_preserves: + forall id body pc extra_pc ifso ifnot pc0, + pc0 < extra_pc -> + PTree.get pc0 (snd (inject_profiling_call id body pc extra_pc ifso ifnot)) = PTree.get pc0 body. +Proof. + intros. simpl. + rewrite PTree.gso by lia. + apply PTree.gso. + lia. +Qed. + +Lemma inject_at_preserves : + forall id body pc extra_pc pc0, + pc0 < extra_pc -> + pc0 <> pc -> + PTree.get pc0 (snd (inject_at id body pc extra_pc)) = PTree.get pc0 body. +Proof. + intros. unfold inject_at. + destruct (PTree.get pc body) eqn:GET. + - destruct i. + all: try (rewrite inject_profiling_call_preserves; trivial; fail). + rewrite inject_profiling_call_preserves by trivial. + apply PTree.gso; lia. + - apply inject_profiling_call_preserves; trivial. +Qed. + +Lemma inject_profiling_call_increases: + forall id body pc extra_pc ifso ifnot, + fst (inject_profiling_call id body pc extra_pc ifso ifnot) = extra_pc + 2. +Proof. + intros. + simpl. + lia. +Qed. + +Lemma inject_at_increases: + forall id body pc extra_pc, + (fst (inject_at id body pc extra_pc)) = extra_pc + 2. +Proof. + intros. unfold inject_at. + destruct (PTree.get pc body). + - destruct i; apply inject_profiling_call_increases. + - apply inject_profiling_call_increases. +Qed. + +Lemma inject_l_preserves : + forall id injections body extra_pc pc0, + pc0 < extra_pc -> + List.forallb (fun injection => if peq injection pc0 then false else true) injections = true -> + PTree.get pc0 (snd (inject_l id body extra_pc injections)) = PTree.get pc0 body. +Proof. + induction injections; + intros until pc0; intros BEFORE ALL; simpl; trivial. + unfold inject_l. + simpl in ALL. + rewrite andb_true_iff in ALL. + destruct ALL as [NEQ ALL]. + simpl. + rewrite pair_expand with (p := inject_at id body a extra_pc). + progress fold (inject_l id (snd (inject_at id body a extra_pc)) + (fst (inject_at id body a extra_pc)) + injections). + rewrite IHinjections; trivial. + - apply inject_at_preserves; trivial. + destruct (peq a pc0); congruence. + - rewrite inject_at_increases. + lia. +Qed. + (* Lemma transf_function_at: forall hash f pc i, @@ -100,7 +178,6 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := match_states (Returnstate stk v m) (Returnstate stk' v m). - Lemma step_simulation: forall s1 t s2 (STEP : step ge s1 t s2) s1' (MS: match_states s1 s1'), -- cgit From 0ef40fc8a82aa7bd92f612b96324ffa58e839151 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 18:35:08 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 41 +++++++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index ad90eb7d..6c85f6a1 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -137,27 +137,36 @@ Proof. lia. Qed. -(* Lemma transf_function_at: - forall hash f pc i, - f.(fn_code)!pc = Some i -> - (match i with - | Icond _ _ _ _ _ => False - | _ => True) -> - (transf_function hash f).(fn_code)!pc = Some i. + forall f pc i + (CODE : f.(fn_code)!pc = Some i) + (INSTR : match i with + | Icond _ _ _ _ _ => False + | _ => True + end), + (transf_function f).(fn_code)!pc = Some i. Proof. - intros until i. intro Hcode. + intros. unfold transf_function; simpl. - destruct (peq pc (Pos.succ (max_pc_function f))) as [EQ | NEQ]. - { assert (pc <= (max_pc_function f))%positive as LE by (eapply max_pc_function_sound; eassumption). - subst pc. - lia. - } - rewrite PTree.gso by congruence. + rewrite inject_l_preserves. assumption. + - pose proof (max_pc_function_sound f pc i CODE) as LE. + unfold Ple in LE. + lia. + - rewrite forallb_forall. + intros x IN. + destruct peq; trivial. + subst x. + unfold gen_conditions in IN. + rewrite in_map_iff in IN. + destruct IN as [[pc' i'] [EQ IN]]. + simpl in EQ. + subst pc'. + apply PTree.elements_complete in IN. + rewrite PTree.gfilter1 in IN. + rewrite CODE in IN. + destruct i; try discriminate; contradiction. Qed. - *) - Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := | match_frames_intro: forall res f sp pc rs, -- cgit From 3b8f4d59dd831c9e58d3c02faab1a863c2fcbad6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 18:43:08 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 6c85f6a1..057be888 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -187,12 +187,36 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := match_states (Returnstate stk v m) (Returnstate stk' v m). +Hint Resolve symbols_preserved : profiling. + Lemma step_simulation: forall s1 t s2 (STEP : step ge s1 t s2) s1' (MS: match_states s1 s1'), exists s2', plus step tge s1' t s2' /\ match_states s2 s2'. Proof. induction 1; intros; inv MS. + - econstructor; split. + + apply plus_one. apply exec_Inop. + erewrite transf_function_at; eauto. apply I. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_Iop with (op:=op) (args:=args). + * erewrite transf_function_at; eauto. apply I. + * rewrite eval_operation_preserved with (ge1:=ge); + eauto with profiling. + + constructor; auto. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. Admitted. (* -- cgit From 42f89ff7198a9f088b428944ffdcc3b488571de5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:06:43 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 057be888..630fecbc 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -205,6 +205,27 @@ Proof. * rewrite eval_operation_preserved with (ge1:=ge); eauto with profiling. + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_Iload with (trap:=trap) (chunk:=chunk) + (addr:=addr) (args:=args) (a:=a). + erewrite transf_function_at; eauto. apply I. + rewrite eval_addressing_preserved with (ge1:=ge). + all: eauto with profiling. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_Iload_notrap1 with (chunk:=chunk) + (addr:=addr) (args:=args). + erewrite transf_function_at; eauto. apply I. + rewrite eval_addressing_preserved with (ge1:=ge). + all: eauto with profiling. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_Iload_notrap2 with (chunk:=chunk) + (addr:=addr) (args:=args) (a:=a). + erewrite transf_function_at; eauto. apply I. + rewrite eval_addressing_preserved with (ge1:=ge). + all: eauto with profiling. + + constructor; auto. - admit. - admit. - admit. @@ -214,9 +235,10 @@ Proof. - admit. - admit. - admit. - - admit. - - admit. - - admit. + - inv STACKS. inv H1. + econstructor; split. + + apply plus_one. apply exec_return. + + constructor; auto. Admitted. (* -- cgit From 0e1a55f98dd47bb65201070722442e9f3e9f16a1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:12:59 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 630fecbc..202e451c 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -187,7 +187,14 @@ Inductive match_states: RTL.state -> RTL.state -> Prop := match_states (Returnstate stk v m) (Returnstate stk' v m). -Hint Resolve symbols_preserved : profiling. +Lemma funsig_preserved: + forall fd, + funsig (transf_fundef fd) = funsig fd. +Proof. + destruct fd; simpl; trivial. +Qed. + +Hint Resolve symbols_preserved funsig_preserved : profiling. Lemma step_simulation: forall s1 t s2 (STEP : step ge s1 t s2) @@ -226,8 +233,21 @@ Proof. rewrite eval_addressing_preserved with (ge1:=ge). all: eauto with profiling. + constructor; auto. - - admit. - - admit. + - econstructor; split. + + apply plus_one. apply exec_Istore with (chunk:=chunk) (src := src) + (addr:=addr) (args:=args) (a:=a). + erewrite transf_function_at; eauto. apply I. + rewrite eval_addressing_preserved with (ge1:=ge). + all: eauto with profiling. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_Icall with (sig:=(funsig fd)) (ros:=ros). + erewrite transf_function_at; eauto. apply I. + apply find_function_translated with (fd := fd). + all: eauto with profiling. + + constructor; auto. + constructor; auto. + constructor. - admit. - admit. - admit. -- cgit From e38366c52fc76edbca3e2842375fdab017356427 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:14:02 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 202e451c..fd905a39 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -248,7 +248,12 @@ Proof. + constructor; auto. constructor; auto. constructor. - - admit. + - econstructor; split. + + apply plus_one. apply exec_Itailcall with (sig:=(funsig fd)) (ros:=ros). + erewrite transf_function_at; eauto. apply I. + apply find_function_translated with (fd := fd). + all: eauto with profiling. + + constructor; auto. - admit. - admit. - admit. -- cgit From 2e7e3340e9739e6317f2fb6049a659d7258aa45b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:17:04 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index fd905a39..1372c9d9 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -194,7 +194,7 @@ Proof. destruct fd; simpl; trivial. Qed. -Hint Resolve symbols_preserved funsig_preserved : profiling. +Hint Resolve symbols_preserved funsig_preserved external_call_symbols_preserved senv_preserved : profiling. Lemma step_simulation: forall s1 t s2 (STEP : step ge s1 t s2) @@ -254,7 +254,13 @@ Proof. apply find_function_translated with (fd := fd). all: eauto with profiling. + constructor; auto. - - admit. + - econstructor; split. + + apply plus_one. + apply exec_Ibuiltin with (ef:=ef) (args:=args) (vargs:=vargs). + erewrite transf_function_at; eauto. apply I. + apply eval_builtin_args_preserved with (ge1:=ge). + all: eauto with profiling. + + constructor; auto. - admit. - admit. - admit. -- cgit From 44e48a67a58a171ca29f22e15429b1baaf64ae81 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:21:30 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 1372c9d9..ed07443c 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -194,7 +194,14 @@ Proof. destruct fd; simpl; trivial. Qed. -Hint Resolve symbols_preserved funsig_preserved external_call_symbols_preserved senv_preserved : profiling. +Lemma stacksize_preserved: + forall f, + fn_stacksize (transf_function f) = fn_stacksize f. +Proof. + destruct f; simpl; trivial. +Qed. + +Hint Resolve symbols_preserved funsig_preserved external_call_symbols_preserved senv_preserved stacksize_preserved : profiling. Lemma step_simulation: forall s1 t s2 (STEP : step ge s1 t s2) @@ -262,8 +269,19 @@ Proof. all: eauto with profiling. + constructor; auto. - admit. - - admit. - - admit. + - econstructor; split. + + apply plus_one. + apply exec_Ijumptable with (arg:=arg) (tbl:=tbl) (n:=n). + erewrite transf_function_at; eauto. apply I. + all: eauto with profiling. + + constructor; auto. + - econstructor; split. + + apply plus_one. + apply exec_Ireturn. + erewrite transf_function_at; eauto. apply I. + rewrite stacksize_preserved. + eassumption. + + constructor; auto. - admit. - admit. - inv STACKS. inv H1. -- cgit From a26610bc11e2c74b8caac1f74979fc2d010d632c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 19:23:47 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index ed07443c..72023792 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -279,11 +279,16 @@ Proof. + apply plus_one. apply exec_Ireturn. erewrite transf_function_at; eauto. apply I. - rewrite stacksize_preserved. - eassumption. + rewrite stacksize_preserved. eassumption. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_function_internal. + rewrite stacksize_preserved. eassumption. + + constructor; auto. + - econstructor; split. + + apply plus_one. apply exec_function_external. + eauto with profiling. + constructor; auto. - - admit. - - admit. - inv STACKS. inv H1. econstructor; split. + apply plus_one. apply exec_return. -- cgit From a838a8d6da926d68219e3c9c4dee021395d03f70 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 20:26:48 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 90 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 72023792..7b770f50 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -137,6 +137,96 @@ Proof. lia. Qed. +Fixpoint inject_l_position extra_pc + (injections : list node) + (k : nat) {struct injections} : node := + match injections with + | nil => extra_pc + | pc::l' => + match k with + | O => extra_pc + | S k' => inject_l_position (extra_pc + 2) l' k' + end + end. + +Lemma inject_l_position_increases : forall injections pc k, + pc <= inject_l_position pc injections k. +Proof. + induction injections; simpl; intros. + lia. + destruct k. + lia. + specialize IHinjections with (pc := pc + 2) (k := k). + lia. +Qed. + +Lemma inject_l_injected0: + forall f_id cond args ifso ifnot expected injections body injnum pc extra_pc + (INSTR : body ! pc = Some (Icond cond args ifso ifnot expected)) + (BELOW : forallb (fun pc => pc Date: Wed, 8 Apr 2020 20:28:22 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 66 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 7b770f50..2b507442 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -226,6 +226,72 @@ Proof. - inv NOREPET. trivial. - trivial. Qed. + +Lemma inject_l_injected1: + forall f_id cond args ifso ifnot expected injections body injnum pc extra_pc + (INSTR : body ! pc = Some (Icond cond args ifso ifnot expected)) + (BELOW : forallb (fun pc => pc Date: Wed, 8 Apr 2020 20:44:20 +0200 Subject: progress in proofs --- backend/Profilingproof.v | 72 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 2b507442..4e7223fc 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -160,6 +160,72 @@ Proof. lia. Qed. +Lemma inject_l_injected_pc: + forall f_id injections cond args ifso ifnot expected body injnum pc extra_pc + (INSTR : body ! pc = Some (Icond cond args ifso ifnot expected)) + (BELOW : forallb (fun pc => pc Date: Wed, 8 Apr 2020 21:17:15 +0200 Subject: last Qed --- backend/Profilingproof.v | 144 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 139 insertions(+), 5 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 4e7223fc..642bc59d 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -234,7 +234,7 @@ Lemma inject_l_injected0: (NUMBER : nth_error injections injnum = Some pc), PTree.get (inject_l_position extra_pc injections injnum) (snd (inject_l f_id body extra_pc injections)) = - Some (Ibuiltin (EF_profiling (branch_id f_id pc) 0%Z) nil BR_none ifso). + Some (Ibuiltin (EF_profiling (branch_id f_id pc) 0%Z) nil BR_none ifnot). Proof. induction injections; intros. { rewrite nth_error_nil in NUMBER. @@ -301,7 +301,7 @@ Lemma inject_l_injected1: (NUMBER : nth_error injections injnum = Some pc), PTree.get (Pos.succ (inject_l_position extra_pc injections injnum)) (snd (inject_l f_id body extra_pc injections)) = - Some (Ibuiltin (EF_profiling (branch_id f_id pc) 1%Z) nil BR_none ifnot). + Some (Ibuiltin (EF_profiling (branch_id f_id pc) 1%Z) nil BR_none ifso). Proof. induction injections; intros. { rewrite nth_error_nil in NUMBER. @@ -491,10 +491,144 @@ Proof. all: eauto with profiling. + constructor; auto. - destruct b. - + econstructor; split. + + assert (In pc (gen_conditions (fn_code f))) as IN. + { unfold gen_conditions. + rewrite in_map_iff. + exists (pc, (Icond cond args ifso ifnot predb)). + split; simpl; trivial. + apply PTree.elements_correct. + rewrite PTree.gfilter1. + rewrite H. + reflexivity. + } + apply In_nth_error in IN. + destruct IN as [n IN]. + econstructor; split. * eapply plus_two. ++ eapply exec_Icond with (cond := cond) (args := args) (predb := predb) (b := true). - + unfold transf_function. simpl. + erewrite inject_l_injected_pc with (cond := cond) (args := args). + ** reflexivity. + ** eassumption. + ** unfold gen_conditions. + rewrite forallb_forall. + intros x INx. + rewrite in_map_iff in INx. + destruct INx as [[x' i'] [EQ INx]]. + simpl in EQ. + subst x'. + apply PTree.elements_complete in INx. + rewrite PTree.gfilter1 in INx. + assert (x <= max_pc_function f) as MAX. + { destruct ((fn_code f) ! x) eqn:CODEx. + 2: discriminate. + apply max_pc_function_sound with (i:=i). + assumption. + } + rewrite Pos.ltb_lt. + lia. + ** unfold gen_conditions. + apply PTree.elements_keys_norepet. + ** exact IN. + ** assumption. + ** reflexivity. + ++ apply exec_Ibuiltin with (ef := (EF_profiling (branch_id (function_id f) pc) 1%Z)) (args := nil) (vargs := nil). + apply inject_l_injected1 with (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot) (expected := predb). + ** exact H. + ** unfold gen_conditions. + rewrite forallb_forall. + intros x INx. + rewrite in_map_iff in INx. + destruct INx as [[x' i'] [EQ INx]]. + simpl in EQ. + subst x'. + apply PTree.elements_complete in INx. + rewrite PTree.gfilter1 in INx. + assert (x <= max_pc_function f) as MAX. + { destruct ((fn_code f) ! x) eqn:CODEx. + 2: discriminate. + apply max_pc_function_sound with (i:=i). + assumption. + } + rewrite Pos.ltb_lt. + lia. + ** unfold gen_conditions. + apply PTree.elements_keys_norepet. + ** exact IN. + ** constructor. + ** constructor. + ++ reflexivity. + * simpl. constructor; auto. + + + assert (In pc (gen_conditions (fn_code f))) as IN. + { unfold gen_conditions. + rewrite in_map_iff. + exists (pc, (Icond cond args ifso ifnot predb)). + split; simpl; trivial. + apply PTree.elements_correct. + rewrite PTree.gfilter1. + rewrite H. + reflexivity. + } + apply In_nth_error in IN. + destruct IN as [n IN]. + econstructor; split. + * eapply plus_two. + ++ eapply exec_Icond with (cond := cond) (args := args) (predb := predb) (b := false). + unfold transf_function. simpl. + erewrite inject_l_injected_pc with (cond := cond) (args := args). + ** reflexivity. + ** eassumption. + ** unfold gen_conditions. + rewrite forallb_forall. + intros x INx. + rewrite in_map_iff in INx. + destruct INx as [[x' i'] [EQ INx]]. + simpl in EQ. + subst x'. + apply PTree.elements_complete in INx. + rewrite PTree.gfilter1 in INx. + assert (x <= max_pc_function f) as MAX. + { destruct ((fn_code f) ! x) eqn:CODEx. + 2: discriminate. + apply max_pc_function_sound with (i:=i). + assumption. + } + rewrite Pos.ltb_lt. + lia. + ** unfold gen_conditions. + apply PTree.elements_keys_norepet. + ** exact IN. + ** assumption. + ** reflexivity. + ++ apply exec_Ibuiltin with (ef := (EF_profiling (branch_id (function_id f) pc) 0%Z)) (args := nil) (vargs := nil). + apply inject_l_injected0 with (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot) (expected := predb). + ** exact H. + ** unfold gen_conditions. + rewrite forallb_forall. + intros x INx. + rewrite in_map_iff in INx. + destruct INx as [[x' i'] [EQ INx]]. + simpl in EQ. + subst x'. + apply PTree.elements_complete in INx. + rewrite PTree.gfilter1 in INx. + assert (x <= max_pc_function f) as MAX. + { destruct ((fn_code f) ! x) eqn:CODEx. + 2: discriminate. + apply max_pc_function_sound with (i:=i). + assumption. + } + rewrite Pos.ltb_lt. + lia. + ** unfold gen_conditions. + apply PTree.elements_keys_norepet. + ** exact IN. + ** constructor. + ** constructor. + ++ reflexivity. + * simpl. constructor; auto. + - econstructor; split. + apply plus_one. apply exec_Ijumptable with (arg:=arg) (tbl:=tbl) (n:=n). @@ -519,7 +653,7 @@ Proof. econstructor; split. + apply plus_one. apply exec_return. + constructor; auto. -Admitted. +Qed. (* - left. econstructor. split. -- cgit From 3bdc0e7a5e6b4d8445001a05322086c84b11dd1e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 21:17:29 +0200 Subject: rm commented-out stuff --- backend/Profilingproof.v | 86 ------------------------------------------------ 1 file changed, 86 deletions(-) diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index 642bc59d..fc04c77e 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -655,92 +655,6 @@ Proof. + constructor; auto. Qed. -(* - - left. econstructor. split. - + eapply plus_one. eapply exec_Inop; eauto with firstnop. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Iop with (v:=v); eauto with firstnop. - rewrite <- H0. - apply eval_operation_preserved. - apply symbols_preserved. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Iload with (v:=v); eauto with firstnop. - all: rewrite <- H0. - all: auto using eval_addressing_preserved, symbols_preserved. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Iload_notrap1; eauto with firstnop. - all: rewrite <- H0; - apply eval_addressing_preserved; - apply symbols_preserved. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Iload_notrap2; eauto with firstnop. - all: rewrite <- H0; - apply eval_addressing_preserved; - apply symbols_preserved. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Istore; eauto with firstnop. - all: rewrite <- H0; - apply eval_addressing_preserved; - apply symbols_preserved. - + constructor; auto with firstnop. - - left. econstructor. split. - + eapply plus_one. eapply exec_Icall. - apply match_pc_same. exact H. - apply find_function_translated. - exact H0. - apply sig_preserved. - + constructor. - constructor; auto. - constructor. - - left. econstructor. split. - + eapply plus_one. eapply exec_Itailcall. - apply match_pc_same. exact H. - apply find_function_translated. - exact H0. - apply sig_preserved. - unfold transf_function; simpl. - eassumption. - + constructor; auto. - - left. econstructor. split. - + eapply plus_one. eapply exec_Ibuiltin; eauto with firstnop. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - + constructor; auto. - - left. econstructor. split. - + eapply plus_one. eapply exec_Icond; eauto with firstnop. - + constructor; auto. - - left. econstructor. split. - + eapply plus_one. eapply exec_Ijumptable; eauto with firstnop. - + constructor; auto. - - left. econstructor. split. - + eapply plus_one. eapply exec_Ireturn; eauto with firstnop. - + constructor; auto. - - left. econstructor. split. - + eapply plus_two. - * eapply exec_function_internal; eauto with firstnop. - * eapply exec_Inop. - unfold transf_function; simpl. - rewrite PTree.gss. - reflexivity. - * auto. - + constructor; auto. - - left. econstructor. split. - + eapply plus_one. eapply exec_function_external; eauto with firstnop. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - + constructor; auto. - - left. - inv STACKS. inv H1. - econstructor; split. - + eapply plus_one. eapply exec_return; eauto. - + constructor; auto. -Qed. - *) - Lemma transf_initial_states: forall S1, RTL.initial_state prog S1 -> exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. -- cgit From d0c54b13ebe86cc6d21a534c6c5c3af6e8c6d350 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 21:29:21 +0200 Subject: fix --- backend/Profiling.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/Profiling.v b/backend/Profiling.v index 0dfc0a0b..4cba49ee 100644 --- a/backend/Profiling.v +++ b/backend/Profiling.v @@ -15,9 +15,9 @@ Section PER_FUNCTION_ID. let id := branch_id f_id pc in let extra_pc' := Pos.succ extra_pc in let prog' := PTree.set extra_pc - (Ibuiltin (EF_profiling id 0%Z) nil BR_none ifso) prog in + (Ibuiltin (EF_profiling id 0%Z) nil BR_none ifnot) prog in let prog'':= PTree.set extra_pc' - (Ibuiltin (EF_profiling id 1%Z) nil BR_none ifnot) prog' in + (Ibuiltin (EF_profiling id 1%Z) nil BR_none ifso) prog' in (Pos.succ extra_pc', prog''). Definition inject_at (prog : code) (pc extra_pc : node) : node * code := @@ -25,7 +25,7 @@ Section PER_FUNCTION_ID. | Some (Icond cond args ifso ifnot expected) => inject_profiling_call (PTree.set pc - (Icond cond args extra_pc (Pos.succ extra_pc) expected) prog) + (Icond cond args (Pos.succ extra_pc) extra_pc expected) prog) pc extra_pc ifso ifnot | _ => inject_profiling_call prog pc extra_pc 1 1 (* does not happen *) end. -- cgit From c794b76ace1824fc58045fa2bc094277fd82e6e3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 21:48:48 +0200 Subject: forgot a file --- backend/ProfilingExploitproof.v | 224 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 backend/ProfilingExploitproof.v diff --git a/backend/ProfilingExploitproof.v b/backend/ProfilingExploitproof.v new file mode 100644 index 00000000..bc68c38e --- /dev/null +++ b/backend/ProfilingExploitproof.v @@ -0,0 +1,224 @@ +Require Import FunInd. +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import ProfilingExploit. + + +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof (Genv.find_funct_transf TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. +Proof. + destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs fd, + find_function ge ros rs = Some fd -> + find_function tge ros rs = Some (transf_fundef fd). +Proof. + unfold find_function; intros. destruct ros as [r|id]. + eapply functions_translated; eauto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence. + eapply function_ptr_translated; eauto. +Qed. + +Lemma transf_function_at: + forall f pc i, + f.(fn_code)!pc = Some i -> + (transf_function f).(fn_code)!pc = Some(transf_instr (function_id f) pc i). +Proof. + intros until i. intro Hcode. + unfold transf_function; simpl. + rewrite PTree.gmap. + unfold option_map. + rewrite Hcode. + reflexivity. +Qed. + +Ltac TR_AT := + match goal with + | [ A: (fn_code _)!_ = Some _ |- _ ] => + generalize (transf_function_at _ _ _ A); intros + end. + + +Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop := + | match_frames_intro: forall res f sp pc rs, + match_frames (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). + +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (State stk f sp pc rs m) + (State stk' (transf_function f) sp pc rs m) + | match_callstates: forall stk f args m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Callstate stk f args m) + (Callstate stk' (transf_fundef f) args m) + | match_returnstates: forall stk v m stk' + (STACKS: list_forall2 match_frames stk stk'), + match_states (Returnstate stk v m) + (Returnstate stk' v m). + +Lemma step_simulation: + forall S1 t S2, RTL.step ge S1 t S2 -> + forall S1', match_states S1 S1' -> + exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'. +Proof. + induction 1; intros S1' MS; inv MS; try TR_AT. +- (* nop *) + econstructor; split. eapply exec_Inop; eauto. + constructor; auto. +- (* op *) + econstructor; split. + eapply exec_Iop with (v := v); eauto. + rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + constructor; auto. +(* load *) +- econstructor; split. + assert (eval_addressing tge sp addr rs ## args = Some a). + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply exec_Iload; eauto. + constructor; auto. +- (* load notrap1 *) + econstructor; split. + assert (eval_addressing tge sp addr rs ## args = None). + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply exec_Iload_notrap1; eauto. + constructor; auto. +- (* load notrap2 *) + econstructor; split. + assert (eval_addressing tge sp addr rs ## args = Some a). + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply exec_Iload_notrap2; eauto. + constructor; auto. +- (* store *) + econstructor; split. + assert (eval_addressing tge sp addr rs ## args = Some a). + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply exec_Istore; eauto. + constructor; auto. +(* call *) +- econstructor; split. + eapply exec_Icall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + constructor. constructor; auto. constructor. +(* tailcall *) +- econstructor; split. + eapply exec_Itailcall with (fd := transf_fundef fd); eauto. + eapply find_function_translated; eauto. + apply sig_preserved. + constructor. auto. +(* builtin *) +- econstructor; split. + eapply exec_Ibuiltin; eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor; auto. +(* cond *) +- destruct predb. + + econstructor; split. + eapply exec_Icond; eauto. + constructor; auto. + + simpl transf_instr in H1. + destruct condition_oracle in H1. + * econstructor; split. + eapply exec_Icond; eauto. + constructor; auto. + * econstructor; split. + eapply exec_Icond; eauto. + constructor; auto. +(* jumptbl *) +- econstructor; split. + eapply exec_Ijumptable; eauto. + constructor; auto. +(* return *) +- econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. +(* internal function *) +- simpl. econstructor; split. + eapply exec_function_internal; eauto. + constructor; auto. +(* external function *) +- econstructor; split. + eapply exec_function_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + constructor; auto. +(* return *) +- inv STACKS. inv H1. + econstructor; split. + eapply exec_return; eauto. + constructor; auto. +Qed. + +Lemma transf_initial_states: + forall S1, RTL.initial_state prog S1 -> + exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2. +Proof. + intros. inv H. econstructor; split. + econstructor. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. + eapply function_ptr_translated; eauto. + rewrite <- H3; apply sig_preserved. + constructor. constructor. +Qed. + +Lemma transf_final_states: + forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r. +Proof. + intros. inv H0. inv H. inv STACKS. constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (RTL.semantics tprog). +Proof. + eapply forward_simulation_step. + apply senv_preserved. + eexact transf_initial_states. + eexact transf_final_states. + exact step_simulation. +Qed. + +End PRESERVATION. -- cgit From 4b67ece83b9ed56bce68c76b7179ae34cbdf0416 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 22:36:10 +0200 Subject: fix Icond now has a extra argument --- backend/CSE3.v | 4 ++-- backend/CSE3analysis.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index d0dc3aef..352cc895 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -62,8 +62,8 @@ Definition transf_instr (fmap : PMap.t RB.t) Icall sig ros (subst_args fmap pc args) dst s | Itailcall sig ros args => Itailcall sig ros (subst_args fmap pc args) - | Icond cond args s1 s2 => - Icond cond (subst_args fmap pc args) s1 s2 + | Icond cond args s1 s2 expected => + Icond cond (subst_args fmap pc args) s1 s2 expected | Ijumptable arg tbl => Ijumptable (subst_arg fmap pc arg) tbl | Ireturn (Some arg) => diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 12fb2d1f..90ce4ce7 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -328,7 +328,7 @@ Section OPERATIONS. Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := match instr with | Inop _ - | Icond _ _ _ _ + | Icond _ _ _ _ _ | Ijumptable _ _ => Some rel | Istore chunk addr args src _ => Some (store chunk addr args src (tenv src) rel) -- cgit From faefa6511fc98977e4af3750ca152441284e8186 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 8 Apr 2020 22:39:20 +0200 Subject: missing cases preventing compilation --- arm/AsmToJSON.ml | 1 + powerpc/AsmToJSON.ml | 1 + 2 files changed, 2 insertions(+) diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml index e850fed6..669d8c0c 100644 --- a/arm/AsmToJSON.ml +++ b/arm/AsmToJSON.ml @@ -177,6 +177,7 @@ let pp_instructions pp ic = | EF_annot_val _ | EF_builtin _ | EF_debug _ + | EF_profiling _ | EF_external _ | EF_free | EF_malloc diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml index f4d4285a..38f4bc75 100644 --- a/powerpc/AsmToJSON.ml +++ b/powerpc/AsmToJSON.ml @@ -365,6 +365,7 @@ let pp_instructions pp ic = | EF_annot_val _ | EF_builtin _ | EF_debug _ + | EF_profiling _ | EF_external _ | EF_free | EF_malloc -- cgit From 3d73bc6d86ceed29317f9d51c3da617613bab595 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 00:04:11 +0200 Subject: update it's now @tlsle not @tprel --- mppa_k1c/TargetPrinter.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index ca1d3229..2489b959 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -219,14 +219,16 @@ module Target (*: TARGET*) = if Archi.pic_code () then begin assert (ofs = Integers.Ptrofs.zero); if C2C.atom_is_thread_local id then begin - fprintf oc " addd %a = $r13, @tprel(%s)\n" ireg r (extern_atom id) + (* fprintf oc " addd %a = $r13, @tprel(%s)\n" ireg r (extern_atom id) *) + fprintf oc " addd %a = $r13, @tlsle(%s)\n" ireg r (extern_atom id) end else begin fprintf oc " make %a = %s\n" ireg r (extern_atom id) end end else begin if C2C.atom_is_thread_local id then begin - fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) + (* fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) *) + fprintf oc " addd %a = $r13, @tlsle(%a)\n" ireg r symbol_offset (id, ofs) end else begin fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) end -- cgit From f38ba5c864ca09b2be8906ae2b0a81e8a57b734b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 00:17:22 +0200 Subject: an example with two threads --- test/monniaux/thread_local/thread_local2.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 test/monniaux/thread_local/thread_local2.c diff --git a/test/monniaux/thread_local/thread_local2.c b/test/monniaux/thread_local/thread_local2.c new file mode 100644 index 00000000..ba244ac6 --- /dev/null +++ b/test/monniaux/thread_local/thread_local2.c @@ -0,0 +1,18 @@ +#include +#include + +_Thread_local int toto; +_Thread_local int toto2 = 45; + +void* poulet(void * dummy) { + printf("%p %p\n", &toto, &toto2); + return NULL; +} + +int main() { + pthread_t thr; + poulet(NULL); + pthread_create(&thr, NULL, poulet, NULL); + pthread_join(thr, NULL); + return 0; +} -- cgit From 1a12e99fcc6c2c1ff3cca70612f3c98493743c68 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Thu, 9 Apr 2020 09:39:46 +0200 Subject: Removed the assertion about prediction on ifso --- backend/Linearizeaux.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 1381877b..9d5a5ba6 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -193,8 +193,9 @@ let forward_sequences code entry = if get_some @@ PTree.get ifnot join_points then ([], [ifso; ifnot]) else let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem) | Some true -> - let errstr = Printf.sprintf ("Inconsistency detected in node %d: ifnot is not the preferred branch") (P.to_int node) in - failwith errstr) + if get_some @@ PTree.get ifso join_points then ([], [ifso; ifnot]) + else let ln, rem = traverse_fallthrough code ifso in (ln, [ifnot] @ rem) + ) | Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end in ([node] @ ln, rem) end -- cgit From 112beeee204d4a06b8c39e9554255261365f3fed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:09:21 +0200 Subject: Makefile for profiling --- test/monniaux/minisat/Makefile.profiled | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 test/monniaux/minisat/Makefile.profiled diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled new file mode 100644 index 00000000..febac0d5 --- /dev/null +++ b/test/monniaux/minisat/Makefile.profiled @@ -0,0 +1,21 @@ +CFILES=main.c solver.c ../clock.c +CCOMP=../../../ccomp +CCOMPFLAGS= +PROFILING_DAT=compcert_profiling.dat +EXECUTE=k1-cluster -- +EXAMPLE=sudoku.sat + +all: minisat.ccomp minisat.branch_linearize minisat.profiled + +minisat.ccomp: $(CFILES) + $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ + +minisat.branch_linearize: $(CFILES) + $(CCOMP) $(CCOMPFLAGS) -fbranchlinearize $(CFILES) -o $@ + +$(PROFILING_DAT): minisat.profile_arcs + -rm -f $(PROFILING_DAT) + $(EXECUTE) $< $(EXAMPLE) + +minisat.profiled: $(CFILES) $(PROFILING_DAT) + $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -fbranchlinearize $(CFILES) -o $@ -- cgit From 07247055911bc1a436e469a3114649d3bb317d73 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:19:33 +0200 Subject: for profiling --- test/monniaux/minisat/Makefile.profiled | 33 +++++++++++++++++++++++++++------ test/monniaux/minisat/clock.c | 1 + 2 files changed, 28 insertions(+), 6 deletions(-) create mode 120000 test/monniaux/minisat/clock.c diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index febac0d5..08283c8a 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -1,21 +1,42 @@ -CFILES=main.c solver.c ../clock.c +CFILES=main.c solver.c clock.c +GCDAFILES=$(CFILES:.c=.gcda) CCOMP=../../../ccomp -CCOMPFLAGS= +GCC=k1-cos-gcc +LIBS=-lm PROFILING_DAT=compcert_profiling.dat EXECUTE=k1-cluster -- EXAMPLE=sudoku.sat -all: minisat.ccomp minisat.branch_linearize minisat.profiled +ALL=minisat.ccomp minisat.branch_linearize minisat.profiled minisat.gcc-O3 minisat.gcc-O3.profiled + +all: $(ALL) minisat.ccomp: $(CFILES) - $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ + $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ $(LIBS) + +minisat.gcc-O3: $(CFILES) + $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) + +minisat.gcc-O3.profile-arcs: $(CFILES) + $(GCC) $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) + +$(GCDAFILES): minisat.gcc-O3.profile-arcs + $(EXECUTE) $< $(EXAMPLE) + +minisat.gcc-O3.profiled: $(CFILES) $(GCDAFILES) + $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) minisat.branch_linearize: $(CFILES) - $(CCOMP) $(CCOMPFLAGS) -fbranchlinearize $(CFILES) -o $@ + $(CCOMP) $(CCOMPFLAGS) -fbranchlinearize $(CFILES) -o $@ $(LIBS) $(PROFILING_DAT): minisat.profile_arcs -rm -f $(PROFILING_DAT) $(EXECUTE) $< $(EXAMPLE) minisat.profiled: $(CFILES) $(PROFILING_DAT) - $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -fbranchlinearize $(CFILES) -o $@ + $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -fbranchlinearize $(CFILES) -o $@ $(LIBS) + +clean: + -rm -f $(ALL) $(PROFILING_DAT) $(GCDAFILES) + +.PHONY: clean diff --git a/test/monniaux/minisat/clock.c b/test/monniaux/minisat/clock.c new file mode 120000 index 00000000..d6bade99 --- /dev/null +++ b/test/monniaux/minisat/clock.c @@ -0,0 +1 @@ +../clock.c \ No newline at end of file -- cgit From 2836e342c9129027dd864dfb215deabec15c5ff9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:23:17 +0200 Subject: Makefile etcZ --- test/monniaux/minisat/Makefile.profiled | 15 ++++++++++----- test/monniaux/minisat/cycles.h | 1 + 2 files changed, 11 insertions(+), 5 deletions(-) create mode 120000 test/monniaux/minisat/cycles.h diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 08283c8a..c5f68fe8 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -7,29 +7,34 @@ PROFILING_DAT=compcert_profiling.dat EXECUTE=k1-cluster -- EXAMPLE=sudoku.sat -ALL=minisat.ccomp minisat.branch_linearize minisat.profiled minisat.gcc-O3 minisat.gcc-O3.profiled +ALL=minisat.ccomp minisat.branch_linearize minisat.profiled minisat.gcc-O3 minisat.gcc-O3.profiled minisat.gcc-O3.profile-arcs minisat.profile-arcs all: $(ALL) minisat.ccomp: $(CFILES) $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ $(LIBS) +minisat.profile-arcs: $(CFILES) + $(CCOMP) $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) + minisat.gcc-O3: $(CFILES) $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) minisat.gcc-O3.profile-arcs: $(CFILES) $(GCC) $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) -$(GCDAFILES): minisat.gcc-O3.profile-arcs +gcda: minisat.gcc-O3.profile-arcs $(EXECUTE) $< $(EXAMPLE) +$(GCDAFILES): gcda + minisat.gcc-O3.profiled: $(CFILES) $(GCDAFILES) $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) minisat.branch_linearize: $(CFILES) - $(CCOMP) $(CCOMPFLAGS) -fbranchlinearize $(CFILES) -o $@ $(LIBS) + $(CCOMP) $(CCOMPFLAGS) -ftracelinearize $(CFILES) -o $@ $(LIBS) -$(PROFILING_DAT): minisat.profile_arcs +$(PROFILING_DAT): minisat.profile-arcs -rm -f $(PROFILING_DAT) $(EXECUTE) $< $(EXAMPLE) @@ -39,4 +44,4 @@ minisat.profiled: $(CFILES) $(PROFILING_DAT) clean: -rm -f $(ALL) $(PROFILING_DAT) $(GCDAFILES) -.PHONY: clean +.PHONY: clean gcda diff --git a/test/monniaux/minisat/cycles.h b/test/monniaux/minisat/cycles.h new file mode 120000 index 00000000..84e54d21 --- /dev/null +++ b/test/monniaux/minisat/cycles.h @@ -0,0 +1 @@ +../cycles.h \ No newline at end of file -- cgit From fc01a94d6be690b37e6de9490a2809f1c9fd71ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:29:09 +0200 Subject: Makefile... --- test/monniaux/minisat/Makefile.profiled | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index c5f68fe8..abd63d32 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -5,43 +5,49 @@ GCC=k1-cos-gcc LIBS=-lm PROFILING_DAT=compcert_profiling.dat EXECUTE=k1-cluster -- +EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat -ALL=minisat.ccomp minisat.branch_linearize minisat.profiled minisat.gcc-O3 minisat.gcc-O3.profiled minisat.gcc-O3.profile-arcs minisat.profile-arcs +ALL=minisat.ccomp.log minisat.branch_linearize.log minisat.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log all: $(ALL) -minisat.ccomp: $(CFILES) +minisat.ccomp.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ $(LIBS) -minisat.profile-arcs: $(CFILES) +minisat.ccomp.profile-arcs.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) -minisat.gcc-O3: $(CFILES) +minisat.gcc-O3.exe: $(CFILES) $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) -minisat.gcc-O3.profile-arcs: $(CFILES) +minisat.gcc-O3.profile-arcs.exe: $(CFILES) $(GCC) $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) -gcda: minisat.gcc-O3.profile-arcs +gcda: minisat.gcc-O3.profile-arcs.exe $(EXECUTE) $< $(EXAMPLE) $(GCDAFILES): gcda -minisat.gcc-O3.profiled: $(CFILES) $(GCDAFILES) +minisat.gcc-O3.profiled.exe: $(CFILES) $(GCDAFILES) $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) -minisat.branch_linearize: $(CFILES) +minisat.ccomp.trace_linearize.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) -ftracelinearize $(CFILES) -o $@ $(LIBS) -$(PROFILING_DAT): minisat.profile-arcs +$(PROFILING_DAT): minisat.ccomp.profile-arcs.exe -rm -f $(PROFILING_DAT) $(EXECUTE) $< $(EXAMPLE) -minisat.profiled: $(CFILES) $(PROFILING_DAT) - $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -fbranchlinearize $(CFILES) -o $@ $(LIBS) +minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) + $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -ftracelinearize $(CFILES) -o $@ $(LIBS) + +%.log : %.exe + $(EXECUTE_CYCLES) $< $(EXAMPLE) 2>&1 | tee $@ clean: -rm -f $(ALL) $(PROFILING_DAT) $(GCDAFILES) .PHONY: clean gcda + +.SECONDARY: -- cgit From 2d9f616cd71bc654b9669e767102d40ab29b05fa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:29:36 +0200 Subject: Makefile... --- test/monniaux/minisat/Makefile.profiled | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index abd63d32..5489bca3 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -8,7 +8,7 @@ EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat -ALL=minisat.ccomp.log minisat.branch_linearize.log minisat.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log +ALL=minisat.ccomp.log minisat.ccomp.branch_linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log all: $(ALL) -- cgit From f650107a94e10c820e478a32457683cdb17ed2c4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:30:03 +0200 Subject: Makefile... --- test/monniaux/minisat/Makefile.profiled | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 5489bca3..3960bc29 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -8,7 +8,7 @@ EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat -ALL=minisat.ccomp.log minisat.ccomp.branch_linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log +ALL=minisat.ccomp.log minisat.ccomp.trace-linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log all: $(ALL) -- cgit From c69d601f9222c1adc4a918d3edb88cf802137a16 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 9 Apr 2020 14:30:21 +0200 Subject: Makefile... --- test/monniaux/minisat/Makefile.profiled | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 3960bc29..860dcb7e 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -32,7 +32,7 @@ $(GCDAFILES): gcda minisat.gcc-O3.profiled.exe: $(CFILES) $(GCDAFILES) $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) -minisat.ccomp.trace_linearize.exe: $(CFILES) +minisat.ccomp.trace-linearize.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) -ftracelinearize $(CFILES) -o $@ $(LIBS) $(PROFILING_DAT): minisat.ccomp.profile-arcs.exe -- cgit From cc8893f2357a832bfd86030c3d80b80439502fec Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 08:25:00 +0200 Subject: begin factorizing profiler --- backend/Profilingaux.ml | 2 +- mppa_k1c/TargetPrinter.ml | 28 ++++++++++++++++++---------- test/monniaux/minisat/Makefile.profiled | 4 ++-- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index 51718303..a1d41ceb 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -55,6 +55,6 @@ let load_profiling_info (filename : string) : unit = let condition_oracle (id : identifier) : bool option = let (count0, count1) = get_counts id in - Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1; + (* Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1; *) if count0 = count1 then None else Some(count1 > count0);; diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 355696de..e154894b 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -272,9 +272,19 @@ module Target (*: TARGET*) = let profiling_counter_table_name = ".compcert_profiling_counters" and profiling_id_table_name = ".compcert_profiling_ids" and profiling_write_table = ".compcert_profiling_write_table" - and profiling_write_table_helper = "_compcert_write_profiling_table";; - - let print_profiling oc = + and profiling_write_table_helper = "_compcert_write_profiling_table" + and dtor_section = ".dtors.65435";; + + let k1c_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name = + fprintf oc " make $r0 = %d\n" nr_items; + fprintf oc " make $r1 = %s\n" profiling_id_table_name; + fprintf oc " make $r2 = %s\n" profiling_counter_table_name; + fprintf oc " goto %s\n" profiling_write_table_helper; + fprintf oc " ;;\n";; + + let print_profiling finalizer_section print_profiling_stub oc = let nr_items = !next_profiling_position in if nr_items > 0 then @@ -286,12 +296,10 @@ module Target (*: TARGET*) = Array.iter (print_profiling_id oc) (profiling_ids ()); fprintf oc " .text\n"; fprintf oc "%s:\n" profiling_write_table; - fprintf oc " make $r0 = %d\n" nr_items; - fprintf oc " make $r1 = %s\n" profiling_id_table_name; - fprintf oc " make $r2 = %s\n" profiling_counter_table_name; - fprintf oc " goto %s\n" profiling_write_table_helper; - fprintf oc " ;;\n"; - fprintf oc " .section .dtors.65435,\"aw\",@progbits\n"; + print_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name; + fprintf oc " .section %s,\"aw\",@progbits\n" finalizer_section; fprintf oc " .align 8\n"; fprintf oc " .8byte %s\n" profiling_write_table end;; @@ -860,7 +868,7 @@ module Target (*: TARGET*) = end let print_epilogue oc = - print_profiling oc; + print_profiling dtor_section k1c_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 860dcb7e..840261b4 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -7,7 +7,7 @@ PROFILING_DAT=compcert_profiling.dat EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat - +CCOMPFLAGS=-finline-auto-threshold 50 ALL=minisat.ccomp.log minisat.ccomp.trace-linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log all: $(ALL) @@ -46,7 +46,7 @@ minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) $(EXECUTE_CYCLES) $< $(EXAMPLE) 2>&1 | tee $@ clean: - -rm -f $(ALL) $(PROFILING_DAT) $(GCDAFILES) + -rm -f *.log *.exe $(PROFILING_DAT) $(GCDAFILES) .PHONY: clean gcda -- cgit From be92a8c71192e014caf292312865dee32ee1b901 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 08:29:28 +0200 Subject: moved to common place --- backend/PrintAsmaux.ml | 56 ++++++++++++++++++++++++++++++++++++++++++++++- mppa_k1c/TargetPrinter.ml | 52 ------------------------------------------- 2 files changed, 55 insertions(+), 53 deletions(-) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index d82e6f84..27d161ee 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -310,4 +310,58 @@ let common_section ?(sec = ".bss") () = if !Clflags.option_fcommon then "COMM" else - sec + sec;; + +(* Profiling *) +let profiling_table : (Digest.t, int) Hashtbl.t = Hashtbl.create 1000;; +let next_profiling_position = ref 0;; +let profiling_position (x : Digest.t) : int = + match Hashtbl.find_opt profiling_table x with + | None -> let y = !next_profiling_position in + next_profiling_position := succ y; + Hashtbl.replace profiling_table x y; + y + | Some y -> y;; + +let profiling_ids () = + let nr_items = !next_profiling_position in + let ar = Array.make nr_items "" in + Hashtbl.iter + (fun x y -> ar.(y) <- x) + profiling_table; + ar;; + +let print_profiling_id oc id = + assert (String.length id = 16); + output_string oc " .byte"; + for i=0 to 15 do + fprintf oc " 0x%02x" (Char.code (String.get id i)); + if i < 15 then output_char oc ',' + done; + output_char oc '\n';; + +let profiling_counter_table_name = ".compcert_profiling_counters" +and profiling_id_table_name = ".compcert_profiling_ids" +and profiling_write_table = ".compcert_profiling_write_table" +and profiling_write_table_helper = "_compcert_write_profiling_table" +and dtor_section = ".dtors.65435";; + +let print_profiling finalizer_section print_profiling_stub oc = + let nr_items = !next_profiling_position in + if nr_items > 0 + then + begin + fprintf oc " .lcomm %s, %d\n" + profiling_counter_table_name (nr_items * 16); + fprintf oc " .section .rodata\n"; + fprintf oc "%s:\n" profiling_id_table_name; + Array.iter (print_profiling_id oc) (profiling_ids ()); + fprintf oc " .text\n"; + fprintf oc "%s:\n" profiling_write_table; + print_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name; + fprintf oc " .section %s,\"aw\",@progbits\n" finalizer_section; + fprintf oc " .align 8\n"; + fprintf oc " .8byte %s\n" profiling_write_table + end;; diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index e154894b..eae05c05 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -242,38 +242,6 @@ module Target (*: TARGET*) = (* Profiling *) - let profiling_table : (Digest.t, int) Hashtbl.t = Hashtbl.create 1000;; - let next_profiling_position = ref 0;; - let profiling_position (x : Digest.t) : int = - match Hashtbl.find_opt profiling_table x with - | None -> let y = !next_profiling_position in - next_profiling_position := succ y; - Hashtbl.replace profiling_table x y; - y - | Some y -> y;; - - let profiling_ids () = - let nr_items = !next_profiling_position in - let ar = Array.make nr_items "" in - Hashtbl.iter - (fun x y -> ar.(y) <- x) - profiling_table; - ar;; - - let print_profiling_id oc id = - assert (String.length id = 16); - output_string oc " .byte"; - for i=0 to 15 do - fprintf oc " 0x%02x" (Char.code (String.get id i)); - if i < 15 then output_char oc ',' - done; - output_char oc '\n';; - - let profiling_counter_table_name = ".compcert_profiling_counters" - and profiling_id_table_name = ".compcert_profiling_ids" - and profiling_write_table = ".compcert_profiling_write_table" - and profiling_write_table_helper = "_compcert_write_profiling_table" - and dtor_section = ".dtors.65435";; let k1c_profiling_stub oc nr_items profiling_id_table_name @@ -284,26 +252,6 @@ module Target (*: TARGET*) = fprintf oc " goto %s\n" profiling_write_table_helper; fprintf oc " ;;\n";; - let print_profiling finalizer_section print_profiling_stub oc = - let nr_items = !next_profiling_position in - if nr_items > 0 - then - begin - fprintf oc " .lcomm %s, %d\n" - profiling_counter_table_name (nr_items * 16); - fprintf oc " .section .rodata\n"; - fprintf oc "%s:\n" profiling_id_table_name; - Array.iter (print_profiling_id oc) (profiling_ids ()); - fprintf oc " .text\n"; - fprintf oc "%s:\n" profiling_write_table; - print_profiling_stub oc nr_items - profiling_id_table_name - profiling_counter_table_name; - fprintf oc " .section %s,\"aw\",@progbits\n" finalizer_section; - fprintf oc " .align 8\n"; - fprintf oc " .8byte %s\n" profiling_write_table - end;; - (* Offset part of a load or store *) let offset oc n = ptrofs oc n -- cgit From 3d0204fddb71ca377fa65952ede872583c8a7242 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 14:06:41 +0200 Subject: various fixes for aarch64 profiling --- aarch64/Asmexpand.ml | 2 +- aarch64/Machregs.v | 1 + aarch64/TargetPrinter.ml | 36 ++++++++++++++++++++++++++++++++ backend/PrintAsmaux.ml | 14 ++++++++++--- mppa_k1c/TargetPrinter.ml | 2 +- test/monniaux/cycles.h | 14 ++++++++++++- test/monniaux/minisat/Makefile.profiled | 16 ++++++++------ test/monniaux/minisat/solver.h | 5 +++++ test/monniaux/profiling/profiling_call.c | 27 ++++++++++++++++++++++++ 9 files changed, 105 insertions(+), 12 deletions(-) create mode 100644 test/monniaux/profiling/profiling_call.c diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 471ad501..b0787d0a 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -400,7 +400,7 @@ let expand_instruction instr = expand_annot_val kind txt targ args res | EF_memcpy(sz, al) -> expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args - | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ | EF_profiling _ -> emit instr | _ -> assert false diff --git a/aarch64/Machregs.v b/aarch64/Machregs.v index b2a2308e..3d27f48f 100644 --- a/aarch64/Machregs.v +++ b/aarch64/Machregs.v @@ -158,6 +158,7 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_memcpy sz al => R15 :: R17 :: R29 :: nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | EF_profiling _ _ => R15 :: R17 :: nil | _ => nil end. diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index e54673dd..bd26a45f 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -227,6 +227,28 @@ module Target : TARGET = | EOuxtw n -> fprintf oc ", uxtw #%a" coqint n | EOuxtx n -> fprintf oc ", uxtx #%a" coqint n + let next_profiling_label = + let atomic_incr_counter = ref 0 in + fun () -> + let r = sprintf ".compcert_atomic_incr%d" !atomic_incr_counter in + incr atomic_incr_counter; r;; + + let print_profiling_logger oc id kind = + assert (kind >= 0); + assert (kind <= 1); + fprintf oc "%s begin profiling %a %d: atomic increment\n" comment + Profilingaux.pp_id id kind; + let ofs = profiling_offset id kind and lbl = next_profiling_label () in + fprintf oc " adrp x15, %s+%d\n" profiling_counter_table_name ofs; + fprintf oc " add x15, x15, :lo12:(%s+%d)\n" profiling_counter_table_name ofs; + fprintf oc "%s:\n" lbl; + fprintf oc " ldaxr x17, [x15]\n"; + fprintf oc " add x17, x17, 1\n"; + fprintf oc " stlxr w17, x17, [x15]\n"; + fprintf oc " cbnz w17, %s\n" lbl; + fprintf oc "%s end profiling %a %d\n" comment + Profilingaux.pp_id id kind;; + (* Printing of instructions *) let print_instruction oc = function (* Branches *) @@ -519,6 +541,8 @@ module Target : TARGET = fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment + | EF_profiling (id, coq_kind) -> + print_profiling_logger oc id (Z.to_int coq_kind) | _ -> assert false end @@ -575,7 +599,19 @@ module Target : TARGET = section oc Section_text; end + let aarch64_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name = + fprintf oc " ret\n"; + fprintf oc " adrp x2, %s\n" profiling_counter_table_name; + fprintf oc " adrp x1, %s\n" profiling_id_table_name; + fprintf oc " add x2, x2, :lo12:%s\n" profiling_counter_table_name; + fprintf oc " add x1, x1, :lo12:%s\n" profiling_id_table_name; + fprintf oc " mov w0, %d\n" nr_items; + fprintf oc " b %s\n" profiling_write_table_helper ;; + let print_epilogue oc = + print_profiling fini_section aarch64_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 27d161ee..153b9412 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -344,7 +344,8 @@ let profiling_counter_table_name = ".compcert_profiling_counters" and profiling_id_table_name = ".compcert_profiling_ids" and profiling_write_table = ".compcert_profiling_write_table" and profiling_write_table_helper = "_compcert_write_profiling_table" -and dtor_section = ".dtors.65435";; +and dtor_section = ".dtors.65435,\"aw\",@progbits" +and fini_section = ".fini_array.00100,\"aw\"";; let print_profiling finalizer_section print_profiling_stub oc = let nr_items = !next_profiling_position in @@ -361,7 +362,14 @@ let print_profiling finalizer_section print_profiling_stub oc = print_profiling_stub oc nr_items profiling_id_table_name profiling_counter_table_name; - fprintf oc " .section %s,\"aw\",@progbits\n" finalizer_section; + fprintf oc " .type %s, @function\n" profiling_write_table; + fprintf oc " .size %s, . - %s\n" profiling_write_table profiling_write_table; + fprintf oc " .section %s\n" finalizer_section; fprintf oc " .align 8\n"; - fprintf oc " .8byte %s\n" profiling_write_table + (if Archi.ptr64 + then fprintf oc " .8byte %s\n" profiling_write_table + else fprintf oc " .4byte %s\n" profiling_write_table) end;; + +let profiling_offset id kind = + ((profiling_position id)*2 + kind)*8;; diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index eae05c05..71979705 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -351,7 +351,7 @@ module Target (*: TARGET*) = fprintf oc " make $r62 = 1\n"; fprintf oc " ;;\n"; fprintf oc " afaddd %d[$r63] = $r62\n" - (((profiling_position id)*2 + kind)*8); + (profiling_offset id kind); fprintf oc " ;;\n" | _ -> assert false diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index c7dc582b..097d6882 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -50,6 +50,11 @@ static inline cycle_t get_cycle(void) { typedef uint32_t cycle_t; #define PRcycle PRId32 +#ifdef ARM_NOPRIVILEGE +static inline cycle_t get_cycle(void) { + return 0; +} +#else /* need this kernel module https://github.com/zertyz/MTL/tree/master/cpp/time/kernel/arm */ static inline cycle_t get_cycle(void) { @@ -57,14 +62,20 @@ static inline cycle_t get_cycle(void) { __asm__ volatile ("mrc p15, 0, %0, c9, c13, 0":"=r" (cycles)); return cycles; } +#endif #else #define PRcycle PRId64 typedef uint64_t cycle_t; + +#ifdef ARM_NOPRIVILEGE +static inline cycle_t get_cycle(void) { + return 0; +} +#else /* need this kernel module: https://github.com/jerinjacobk/armv8_pmu_cycle_counter_el0 on 5+ kernels, remove first argument of access_ok macro */ - static inline cycle_t get_cycle(void) { uint64_t val; @@ -72,6 +83,7 @@ static inline cycle_t get_cycle(void) return val; } #endif +#endif #else #define PRcycle PRId32 diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 840261b4..349089b7 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -1,28 +1,32 @@ +# -*- mode: makefile; -*- + CFILES=main.c solver.c clock.c GCDAFILES=$(CFILES:.c=.gcda) CCOMP=../../../ccomp -GCC=k1-cos-gcc +GCC=aarch64-linux-gnu-gcc # k1-cos-gcc LIBS=-lm PROFILING_DAT=compcert_profiling.dat -EXECUTE=k1-cluster -- +EXECUTE=qemu-aarch64 # k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat -CCOMPFLAGS=-finline-auto-threshold 50 +CCOMPFLAGS=-finline-auto-threshold 50 -static -finline-asm +GCCFLAGS=-static ALL=minisat.ccomp.log minisat.ccomp.trace-linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log all: $(ALL) +exe: $(ALL:.log=.exe) minisat.ccomp.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ $(LIBS) minisat.ccomp.profile-arcs.exe: $(CFILES) - $(CCOMP) $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) + $(CCOMP) -DAMD_NO_PRIVILEGE $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) minisat.gcc-O3.exe: $(CFILES) $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) minisat.gcc-O3.profile-arcs.exe: $(CFILES) - $(GCC) $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) + $(GCC) -DAMD_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) gcda: minisat.gcc-O3.profile-arcs.exe $(EXECUTE) $< $(EXAMPLE) @@ -48,6 +52,6 @@ minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) clean: -rm -f *.log *.exe $(PROFILING_DAT) $(GCDAFILES) -.PHONY: clean gcda +.PHONY: clean gcda exe all .SECONDARY: diff --git a/test/monniaux/minisat/solver.h b/test/monniaux/minisat/solver.h index c9ce0219..4b96b017 100644 --- a/test/monniaux/minisat/solver.h +++ b/test/monniaux/minisat/solver.h @@ -19,6 +19,8 @@ OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWA **************************************************************************************************/ // Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko +#include + #ifndef solver_h #define solver_h @@ -39,11 +41,14 @@ static const bool false = 0; typedef int lit; typedef char lbool; +#if 0 #ifdef _WIN32 typedef signed __int64 uint64; // compatible with MS VS 6.0 #else typedef unsigned long long uint64; #endif +#endif +typedef uint64_t uint64; static const int var_Undef = -1; static const lit lit_Undef = -2; diff --git a/test/monniaux/profiling/profiling_call.c b/test/monniaux/profiling/profiling_call.c new file mode 100644 index 00000000..ce20241d --- /dev/null +++ b/test/monniaux/profiling/profiling_call.c @@ -0,0 +1,27 @@ +/* +For knowing how to write assembly profiling stubs. + */ + +#include +#include +#include + +typedef uint8_t md5_hash[16]; +typedef uint64_t condition_counters[2]; + +void _compcert_write_profiling_table(unsigned int nr_items, + md5_hash id_table[], + condition_counters counter_table[]); + +static md5_hash id_table[42] = {{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16}}; +static condition_counters counter_table[42]; + +void write_profile(void) { + _compcert_write_profiling_table(42, id_table, counter_table); +} + +static _Atomic uint64_t counter; + +void incr_counter(void) { + counter++; +} -- cgit From 76f48469c4b4ca49159dc736830cd806f8dbbf07 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 14:57:37 +0200 Subject: fix write table --- backend/PrintAsmaux.ml | 1 - runtime/c/write_profiling_table.c | 4 ++++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 153b9412..5a074867 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -365,7 +365,6 @@ let print_profiling finalizer_section print_profiling_stub oc = fprintf oc " .type %s, @function\n" profiling_write_table; fprintf oc " .size %s, . - %s\n" profiling_write_table profiling_write_table; fprintf oc " .section %s\n" finalizer_section; - fprintf oc " .align 8\n"; (if Archi.ptr64 then fprintf oc " .8byte %s\n" profiling_write_table else fprintf oc " .4byte %s\n" profiling_write_table) diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 5c55c4b6..06cb15da 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -27,6 +27,7 @@ void _compcert_write_profiling_table(unsigned int nr_items, errno = 0; FILE *fp = fopen("compcert_profiling.dat", "a"); + fprintf(stderr, "successfully opened profiling file\n"); if (fp == NULL) { perror("open CompCert profiling data for writing"); return; @@ -37,10 +38,13 @@ void _compcert_write_profiling_table(unsigned int nr_items, write_counter(fp, counter_table[i][0]); write_counter(fp, counter_table[i][1]); } + fprintf(stderr, "successfully written profiling file\n"); fclose(fp); + fprintf(stderr, "successfully closed profiling file\n"); if (errno != 0) { perror("write CompCert profiling data"); return; } + fprintf(stderr, "no error\n"); } -- cgit From 5659daa886559566fdb6306d989578707838a267 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 16:47:51 +0200 Subject: profiling still crashes on Aarch64 --- aarch64/TargetPrinter.ml | 1 - runtime/Makefile | 2 +- runtime/c/write_profiling_table.c | 8 ++++---- test/monniaux/cycles.h | 4 ++-- test/monniaux/minisat/Makefile.profiled | 4 ++-- 5 files changed, 9 insertions(+), 10 deletions(-) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index bd26a45f..0eaf3923 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -602,7 +602,6 @@ module Target : TARGET = let aarch64_profiling_stub oc nr_items profiling_id_table_name profiling_counter_table_name = - fprintf oc " ret\n"; fprintf oc " adrp x2, %s\n" profiling_counter_table_name; fprintf oc " adrp x1, %s\n" profiling_id_table_name; fprintf oc " add x2, x2, :lo12:%s\n" profiling_counter_table_name; diff --git a/runtime/Makefile b/runtime/Makefile index c9883577..bf979d5f 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -73,7 +73,7 @@ $(LIB): $(OBJS) # generated assembly %.o: c/%.c c/i64.h ../ccomp - ../ccomp -O2 -S -o $*.s -I./c c/$*.c + ../ccomp -g -O2 -S -o $*.s -I./c c/$*.c sed -i -e 's/i64_/__compcert_i64_/g' $*.s $(CASMRUNTIME) -o $*.o $*.s @rm $*.s diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 06cb15da..3c7303e4 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -27,7 +27,7 @@ void _compcert_write_profiling_table(unsigned int nr_items, errno = 0; FILE *fp = fopen("compcert_profiling.dat", "a"); - fprintf(stderr, "successfully opened profiling file\n"); + //fprintf(stderr, "successfully opened profiling file\n"); if (fp == NULL) { perror("open CompCert profiling data for writing"); return; @@ -38,13 +38,13 @@ void _compcert_write_profiling_table(unsigned int nr_items, write_counter(fp, counter_table[i][0]); write_counter(fp, counter_table[i][1]); } - fprintf(stderr, "successfully written profiling file\n"); + //fprintf(stderr, "successfully written profiling file\n"); fclose(fp); - fprintf(stderr, "successfully closed profiling file\n"); + //fprintf(stderr, "successfully closed profiling file\n"); if (errno != 0) { perror("write CompCert profiling data"); return; } - fprintf(stderr, "no error\n"); + //fprintf(stderr, "no error\n"); } diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index 097d6882..36de6cc5 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -50,7 +50,7 @@ static inline cycle_t get_cycle(void) { typedef uint32_t cycle_t; #define PRcycle PRId32 -#ifdef ARM_NOPRIVILEGE +#ifdef ARM_NO_PRIVILEGE static inline cycle_t get_cycle(void) { return 0; } @@ -67,7 +67,7 @@ static inline cycle_t get_cycle(void) { #define PRcycle PRId64 typedef uint64_t cycle_t; -#ifdef ARM_NOPRIVILEGE +#ifdef ARM_NO_PRIVILEGE static inline cycle_t get_cycle(void) { return 0; } diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 349089b7..2c078f28 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -20,13 +20,13 @@ minisat.ccomp.exe: $(CFILES) $(CCOMP) $(CCOMPFLAGS) $(CFILES) -o $@ $(LIBS) minisat.ccomp.profile-arcs.exe: $(CFILES) - $(CCOMP) -DAMD_NO_PRIVILEGE $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) + $(CCOMP) -DARM_NO_PRIVILEGE $(CCOMPFLAGS) -fprofile-arcs $(CFILES) -o $@ $(LIBS) minisat.gcc-O3.exe: $(CFILES) $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) minisat.gcc-O3.profile-arcs.exe: $(CFILES) - $(GCC) -DAMD_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) + $(GCC) -DARM_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) gcda: minisat.gcc-O3.profile-arcs.exe $(EXECUTE) $< $(EXAMPLE) -- cgit From b19b9defebf96ba8599f481d4c617d43c21642ef Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 18:09:34 +0200 Subject: use proper local labels --- aarch64/TargetPrinter.ml | 2 +- backend/Profilingaux.ml | 5 +++-- runtime/c/write_profiling_table.c | 2 +- test/monniaux/minisat/Makefile.profiled | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 0eaf3923..9d605336 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -230,7 +230,7 @@ module Target : TARGET = let next_profiling_label = let atomic_incr_counter = ref 0 in fun () -> - let r = sprintf ".compcert_atomic_incr%d" !atomic_incr_counter in + let r = sprintf ".Lcompcert_atomic_incr%d" !atomic_incr_counter in incr atomic_incr_counter; r;; let print_profiling_logger oc id kind = diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index a1d41ceb..0ba739c2 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -48,13 +48,14 @@ let load_profiling_info (filename : string) : unit = let id : identifier = really_input_string ic 16 in let counter0 = input_counter ic in let counter1 = input_counter ic in - (* Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id counter0 counter1; *) + (* Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id counter0 counter1 *) add_profiling_counts id counter0 counter1 done with End_of_file -> close_in ic;; let condition_oracle (id : identifier) : bool option = let (count0, count1) = get_counts id in - (* Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1; *) + (if count0 <> 0L || count1 <> 0L then + Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1); if count0 = count1 then None else Some(count1 > count0);; diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 3c7303e4..60bae3d7 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -46,5 +46,5 @@ void _compcert_write_profiling_table(unsigned int nr_items, perror("write CompCert profiling data"); return; } - //fprintf(stderr, "no error\n"); + fprintf(stderr, "write CompCert profiling data: no error\n"); } diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 2c078f28..64e7cb80 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -41,7 +41,7 @@ minisat.ccomp.trace-linearize.exe: $(CFILES) $(PROFILING_DAT): minisat.ccomp.profile-arcs.exe -rm -f $(PROFILING_DAT) - $(EXECUTE) $< $(EXAMPLE) + $(EXECUTE) $< $(EXAMPLE) || true minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -ftracelinearize $(CFILES) -o $@ $(LIBS) -- cgit From 50d59f7ab7ae06de2ae6439752f0b56695d539df Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 20:55:44 +0200 Subject: fix writing profiling info for Aarch64 --- aarch64/TargetPrinter.ml | 8 +++++++- backend/PrintAsmaux.ml | 39 ++++++++++++++++++++++++++++++--------- mppa_k1c/TargetPrinter.ml | 2 +- 3 files changed, 38 insertions(+), 11 deletions(-) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 9d605336..5f62c936 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -608,9 +608,15 @@ module Target : TARGET = fprintf oc " add x1, x1, :lo12:%s\n" profiling_id_table_name; fprintf oc " mov w0, %d\n" nr_items; fprintf oc " b %s\n" profiling_write_table_helper ;; + + let print_atexit oc to_be_called = + fprintf oc " adrp x0, %s\n" to_be_called; + fprintf oc " add x0, x0, :lo12:%s\n" to_be_called; + fprintf oc " b atexit\n";; + let print_epilogue oc = - print_profiling fini_section aarch64_profiling_stub oc; + print_profiling_epilogue (Init_atexit print_atexit) aarch64_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 5a074867..c7161615 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -342,12 +342,27 @@ let print_profiling_id oc id = let profiling_counter_table_name = ".compcert_profiling_counters" and profiling_id_table_name = ".compcert_profiling_ids" -and profiling_write_table = ".compcert_profiling_write_table" +and profiling_write_table = ".compcert_profiling_save_for_this_object" +and profiling_init = ".compcert_profiling_init" and profiling_write_table_helper = "_compcert_write_profiling_table" and dtor_section = ".dtors.65435,\"aw\",@progbits" -and fini_section = ".fini_array.00100,\"aw\"";; +(* and fini_section = ".fini_array_00100,\"aw\"" *) +and init_section = ".init_array,\"aw\"";; -let print_profiling finalizer_section print_profiling_stub oc = +type finalizer_call_method = + | Dtors + | Init_atexit of (out_channel -> string -> unit);; + +let write_symbol_pointer oc sym = + if Archi.ptr64 + then fprintf oc " .8byte %s\n" sym + else fprintf oc " .4byte %s\n" sym;; + +let declare_function oc name = + fprintf oc " .type %s, @function\n" name; + fprintf oc " .size %s, . - %s\n" name name;; + +let print_profiling_epilogue finalizer_call_method print_profiling_stub oc = let nr_items = !next_profiling_position in if nr_items > 0 then @@ -362,12 +377,18 @@ let print_profiling finalizer_section print_profiling_stub oc = print_profiling_stub oc nr_items profiling_id_table_name profiling_counter_table_name; - fprintf oc " .type %s, @function\n" profiling_write_table; - fprintf oc " .size %s, . - %s\n" profiling_write_table profiling_write_table; - fprintf oc " .section %s\n" finalizer_section; - (if Archi.ptr64 - then fprintf oc " .8byte %s\n" profiling_write_table - else fprintf oc " .4byte %s\n" profiling_write_table) + declare_function oc profiling_write_table; + match finalizer_call_method with + | Dtors -> + fprintf oc " .section %s\n" dtor_section; + write_symbol_pointer oc profiling_write_table + | Init_atexit(atexit_call) -> + fprintf oc " .section %s\n" init_section; + write_symbol_pointer oc profiling_init; + fprintf oc " .text\n"; + fprintf oc "%s:\n" profiling_init; + atexit_call oc profiling_write_table; + declare_function oc profiling_init end;; let profiling_offset id kind = diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 71979705..61fe5e90 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -816,7 +816,7 @@ module Target (*: TARGET*) = end let print_epilogue oc = - print_profiling dtor_section k1c_profiling_stub oc; + print_profiling_epilogue Dtors k1c_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; -- cgit From 1348bc74b48ea8cb366a8bfab379699137276292 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 22:33:26 +0200 Subject: fixing Makefile --- test/monniaux/minisat/Makefile.profiled | 14 +++++++++----- test/monniaux/minisat/k1c.inline_50.log | 14 ++++++++++++++ 2 files changed, 23 insertions(+), 5 deletions(-) create mode 100644 test/monniaux/minisat/k1c.inline_50.log diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 64e7cb80..b3b3c2fc 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -3,11 +3,15 @@ CFILES=main.c solver.c clock.c GCDAFILES=$(CFILES:.c=.gcda) CCOMP=../../../ccomp -GCC=aarch64-linux-gnu-gcc # k1-cos-gcc + +GCC=aarch64-linux-gnu-gcc +GCC=k1-cos-gcc +EXECUTE=qemu-aarch64 +EXECUTE=k1-cluster -- +EXECUTE_CYCLES=k1-cluster --cycle-based -- + LIBS=-lm PROFILING_DAT=compcert_profiling.dat -EXECUTE=qemu-aarch64 # k1-cluster -- -EXECUTE_CYCLES=k1-cluster --cycle-based -- EXAMPLE=sudoku.sat CCOMPFLAGS=-finline-auto-threshold 50 -static -finline-asm GCCFLAGS=-static @@ -37,11 +41,11 @@ minisat.gcc-O3.profiled.exe: $(CFILES) $(GCDAFILES) $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) minisat.ccomp.trace-linearize.exe: $(CFILES) - $(CCOMP) $(CCOMPFLAGS) -ftracelinearize $(CFILES) -o $@ $(LIBS) + $(CCOMP) $(CCOMPFLAGS) -fduplicate 0 -ftracelinearize $(CFILES) -o $@ $(LIBS) $(PROFILING_DAT): minisat.ccomp.profile-arcs.exe -rm -f $(PROFILING_DAT) - $(EXECUTE) $< $(EXAMPLE) || true + $(EXECUTE) $< $(EXAMPLE) minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -ftracelinearize $(CFILES) -o $@ $(LIBS) diff --git a/test/monniaux/minisat/k1c.inline_50.log b/test/monniaux/minisat/k1c.inline_50.log new file mode 100644 index 00000000..438a06b4 --- /dev/null +++ b/test/monniaux/minisat/k1c.inline_50.log @@ -0,0 +1,14 @@ +==> minisat.ccomp.log <== +time cycles: 3252345 + +==> minisat.ccomp.profiled.log <== +time cycles: 3150170 + +==> minisat.ccomp.trace-linearize.log <== +time cycles: 3192299 + +==> minisat.gcc-O3.log <== +time cycles: 2780324 + +==> minisat.gcc-O3.profiled.log <== +time cycles: 2487533 -- cgit From a3d856e24b2ac6577678a1535e4d15316cf0755c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 22:54:20 +0200 Subject: fix for running the profile code on host --- test/monniaux/minisat/Makefile.profiled | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index b3b3c2fc..f411b5e7 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -1,13 +1,12 @@ # -*- mode: makefile; -*- CFILES=main.c solver.c clock.c -GCDAFILES=$(CFILES:.c=.gcda) CCOMP=../../../ccomp GCC=aarch64-linux-gnu-gcc -GCC=k1-cos-gcc +#GCC=k1-cos-gcc EXECUTE=qemu-aarch64 -EXECUTE=k1-cluster -- +#EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- LIBS=-lm @@ -29,13 +28,16 @@ minisat.ccomp.profile-arcs.exe: $(CFILES) minisat.gcc-O3.exe: $(CFILES) $(GCC) $(GCCFLAGS) -O3 $(CFILES) -o $@ $(LIBS) -minisat.gcc-O3.profile-arcs.exe: $(CFILES) - $(GCC) -DARM_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $(CFILES) -o $@ $(LIBS) +clock.gcc-O3.noprofile.o : clock.c + $(GCC) -DARM_NO_PRIVILEGE $(GCCFLAGS) -O3 -c $< -o @ + +minisat.gcc-O3.profile-arcs.exe: main.c solver.c clock.gcc-O3.noprofile.o + $(GCC) -DARM_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $+ -o $@ $(LIBS) gcda: minisat.gcc-O3.profile-arcs.exe $(EXECUTE) $< $(EXAMPLE) -$(GCDAFILES): gcda +main.gcda solver.gcda: gcda minisat.gcc-O3.profiled.exe: $(CFILES) $(GCDAFILES) $(GCC) $(GCCFLAGS) -O3 -fprofile-use $(CFILES) -o $@ $(LIBS) -- cgit From 1f6cb381b91fc40d1e6b7c6ae1f022077f6091de Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 10 Apr 2020 23:17:14 +0200 Subject: for running benchmarks on marte --- test/monniaux/minisat/Makefile.on_marte | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 test/monniaux/minisat/Makefile.on_marte diff --git a/test/monniaux/minisat/Makefile.on_marte b/test/monniaux/minisat/Makefile.on_marte new file mode 100644 index 00000000..af7b9145 --- /dev/null +++ b/test/monniaux/minisat/Makefile.on_marte @@ -0,0 +1,16 @@ +EXE=minisat.ccomp.exe minisat.ccomp.trace-linearize.exe \ + minisat.gcc-O3.exe \ + minisat.ccomp.profiled.exe minisat.gcc-O3.profiled.exe + +LOG=$(EXE:.exe=.dat) + +all: $(LOG) + +%.log : %.exe + rm -f $@ + for i in `seq 1 1000` ; do ./$< sudoku.sat >> $@; done + +%.dat : %.log + grep 'time cycles: ' $< | sed -e 's/time cycles: //' | awk '{ total += $$1; count++ } END { print total/count }' > $@ + +.SECONDARY: -- cgit From f50a1c1e1dc194c78b68ecdc7e3f6c0b0448f5f4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 Apr 2020 10:29:45 +0200 Subject: seems like the ARM profiling perhaps works --- arm/Asmexpand.ml | 2 +- arm/Constantexpand.ml | 1 + arm/Machregs.v | 1 + arm/TargetPrinter.ml | 53 ++++++++++++++++++++++++++++++++- backend/PrintAsmaux.ml | 6 +--- test/monniaux/minisat/Makefile.profiled | 3 +- 6 files changed, 58 insertions(+), 8 deletions(-) diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 89aab5c7..6996c9bb 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -619,7 +619,7 @@ let expand_instruction instr = | EF_memcpy(sz, al) -> expand_builtin_memcpy (Int32.to_int (camlint_of_coqint sz)) (Int32.to_int (camlint_of_coqint al)) args - | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ | EF_profiling _ -> emit instr | _ -> assert false diff --git a/arm/Constantexpand.ml b/arm/Constantexpand.ml index 408b291e..8cc32c1f 100644 --- a/arm/Constantexpand.ml +++ b/arm/Constantexpand.ml @@ -106,6 +106,7 @@ let estimate_size = function | Pbuiltin (ef,_,_) -> begin match ef with | EF_inline_asm _ -> 256 + | EF_profiling _ -> 40 | _ -> 0 end | Pcfi_adjust _ | Pcfi_rel_offset _ diff --git a/arm/Machregs.v b/arm/Machregs.v index ae0ff6bf..1ec8f0a1 100644 --- a/arm/Machregs.v +++ b/arm/Machregs.v @@ -153,6 +153,7 @@ Definition destroyed_by_builtin (ef: external_function): list mreg := match ef with | EF_memcpy sz al => R2 :: R3 :: R12 :: F7 :: nil | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | EF_profiling _ _ => R2 :: R3 :: R12 :: nil | _ => nil end. diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml index 03e06a65..2499dd31 100644 --- a/arm/TargetPrinter.ml +++ b/arm/TargetPrinter.ml @@ -202,6 +202,38 @@ struct | SOasr(r, n) -> fprintf oc "%a, asr #%a" ireg r coqint n | SOror(r, n) -> fprintf oc "%a, ror #%a" ireg r coqint n + + let next_profiling_label = + let profiling_label_counter = ref 0 in + fun () -> + let r = sprintf ".Lprofiling_label%d" !profiling_label_counter in + incr profiling_label_counter; r;; + + let print_profiling_logger oc id kind = + assert (kind >= 0); + assert (kind <= 1); + let ofs = profiling_offset id kind and olbl = next_profiling_label () in + fprintf oc "%s begin profiling %a %d: non-atomic increment\n" comment + Profilingaux.pp_id id kind; + fprintf oc " ldr r2, %s\n" olbl; + fprintf oc " ldr r3, [r2, #%d]\n" + (if Configuration.is_big_endian then 8 else 0); + fprintf oc " ldr r12, [r2, #%d]\n" + (if Configuration.is_big_endian then 0 else 8); + fprintf oc " adds r3, r3, #1\n"; + fprintf oc " adc r12, r12, #0\n"; + fprintf oc " str r3, [r2, #%d]\n" + (if Configuration.is_big_endian then 8 else 0); + fprintf oc " str r12, [r2, #%d]\n" + (if Configuration.is_big_endian then 0 else 8); + let jlbl = next_profiling_label () in + fprintf oc " b %s\n" jlbl; + fprintf oc "%s:\n" olbl; + fprintf oc " .word %s + %d\n" profiling_counter_table_name ofs; + fprintf oc "%s:\n" jlbl; + fprintf oc "%s end profiling %a %d\n" comment + Profilingaux.pp_id id kind;; + let print_instruction oc = function (* Core instructions *) | Padc (r1,r2,so) -> @@ -482,6 +514,7 @@ struct fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment + | EF_profiling(id, coq_kind) -> print_profiling_logger oc id (Z.to_int coq_kind) | _ -> assert false end @@ -549,6 +582,11 @@ struct if !Clflags.option_mthumb then fprintf oc " .thumb_func\n" + + let text_print_fun_info oc name = + fprintf oc " .type %s, %%function\n" name; + fprintf oc " .size %s, . - %s\n" name name + let print_fun_info oc name = fprintf oc " .type %a, %%function\n" symbol name; fprintf oc " .size %a, . - %a\n" symbol name symbol name @@ -596,9 +634,22 @@ struct if !Clflags.option_g then begin section oc Section_text; cfi_section oc - end + end + + let arm_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name = + fprintf oc " ldr r2, = %s\n" profiling_counter_table_name; + fprintf oc " ldr r1, = %s\n" profiling_id_table_name; + fprintf oc " mov r0, #%d\n" nr_items; + fprintf oc " b %s\n" profiling_write_table_helper;; + + let print_atexit oc to_be_called = + fprintf oc " ldr r0, = %s\n" to_be_called; + fprintf oc " b atexit\n";; let print_epilogue oc = + print_profiling_epilogue text_print_fun_info (Init_atexit print_atexit) arm_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index c7161615..cc7b33c3 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -358,11 +358,7 @@ let write_symbol_pointer oc sym = then fprintf oc " .8byte %s\n" sym else fprintf oc " .4byte %s\n" sym;; -let declare_function oc name = - fprintf oc " .type %s, @function\n" name; - fprintf oc " .size %s, . - %s\n" name name;; - -let print_profiling_epilogue finalizer_call_method print_profiling_stub oc = +let print_profiling_epilogue declare_function finalizer_call_method print_profiling_stub oc = let nr_items = !next_profiling_position in if nr_items > 0 then diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index f411b5e7..fac3e3af 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -5,7 +5,8 @@ CCOMP=../../../ccomp GCC=aarch64-linux-gnu-gcc #GCC=k1-cos-gcc -EXECUTE=qemu-aarch64 +#EXECUTE=qemu-aarch64 +EXECUTE=qemu-arm #EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- -- cgit From 5862a7517105b822224191e05ff203924e408ed5 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 Apr 2020 11:24:30 +0200 Subject: fix for aarch64 --- aarch64/TargetPrinter.ml | 2 +- backend/PrintAsmaux.ml | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml index 5f62c936..ef9045ea 100644 --- a/aarch64/TargetPrinter.ml +++ b/aarch64/TargetPrinter.ml @@ -616,7 +616,7 @@ module Target : TARGET = let print_epilogue oc = - print_profiling_epilogue (Init_atexit print_atexit) aarch64_profiling_stub oc; + print_profiling_epilogue elf_text_print_fun_info (Init_atexit print_atexit) aarch64_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index cc7b33c3..25792df5 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -111,6 +111,10 @@ let elf_symbol_offset oc (symb, ofs) = if ofs <> 0L then fprintf oc " + %Ld" ofs (* Functions for fun and var info *) +let elf_text_print_fun_info oc name = + fprintf oc " .type %s, @function\n" name; + fprintf oc " .size %s, . - %s\n" name name + let elf_print_fun_info oc name = fprintf oc " .type %a, @function\n" elf_symbol name; fprintf oc " .size %a, . - %a\n" elf_symbol name elf_symbol name -- cgit From 7d15566ad116730c1452364bc0fe3d2dc714e5ed Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 Apr 2020 11:55:46 +0200 Subject: fix for k1c --- mppa_k1c/TargetPrinter.ml | 2 +- test/monniaux/minisat/Makefile.profiled | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 61fe5e90..da009a0d 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -816,7 +816,7 @@ module Target (*: TARGET*) = end let print_epilogue oc = - print_profiling_epilogue Dtors k1c_profiling_stub oc; + print_profiling_epilogue elf_text_print_fun_info Dtors k1c_profiling_stub oc; if !Clflags.option_g then begin Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); section oc Section_text; diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index fac3e3af..e66db1db 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -5,8 +5,8 @@ CCOMP=../../../ccomp GCC=aarch64-linux-gnu-gcc #GCC=k1-cos-gcc -#EXECUTE=qemu-aarch64 -EXECUTE=qemu-arm +EXECUTE=qemu-aarch64 +#EXECUTE=qemu-arm #EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- -- cgit From 7299996cac6c4747b6611b17f0af15fb08c6ee80 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 11 Apr 2020 22:02:46 +0200 Subject: fix reverse printing problem for hashes --- backend/PrintAsmaux.ml | 54 +++++++++++++++++---------------- backend/Profilingaux.ml | 38 ++++++++++++++--------- common/PrintAST.ml | 9 +++++- test/monniaux/minisat/Makefile.profiled | 10 +++--- 4 files changed, 65 insertions(+), 46 deletions(-) diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml index 25792df5..7a281684 100644 --- a/backend/PrintAsmaux.ml +++ b/backend/PrintAsmaux.ml @@ -363,33 +363,35 @@ let write_symbol_pointer oc sym = else fprintf oc " .4byte %s\n" sym;; let print_profiling_epilogue declare_function finalizer_call_method print_profiling_stub oc = - let nr_items = !next_profiling_position in - if nr_items > 0 + if !Clflags.option_profile_arcs then - begin - fprintf oc " .lcomm %s, %d\n" - profiling_counter_table_name (nr_items * 16); - fprintf oc " .section .rodata\n"; - fprintf oc "%s:\n" profiling_id_table_name; - Array.iter (print_profiling_id oc) (profiling_ids ()); - fprintf oc " .text\n"; - fprintf oc "%s:\n" profiling_write_table; - print_profiling_stub oc nr_items - profiling_id_table_name - profiling_counter_table_name; - declare_function oc profiling_write_table; - match finalizer_call_method with - | Dtors -> - fprintf oc " .section %s\n" dtor_section; - write_symbol_pointer oc profiling_write_table - | Init_atexit(atexit_call) -> - fprintf oc " .section %s\n" init_section; - write_symbol_pointer oc profiling_init; - fprintf oc " .text\n"; - fprintf oc "%s:\n" profiling_init; - atexit_call oc profiling_write_table; - declare_function oc profiling_init - end;; + let nr_items = !next_profiling_position in + if nr_items > 0 + then + begin + fprintf oc " .lcomm %s, %d\n" + profiling_counter_table_name (nr_items * 16); + fprintf oc " .section .rodata\n"; + fprintf oc "%s:\n" profiling_id_table_name; + Array.iter (print_profiling_id oc) (profiling_ids ()); + fprintf oc " .text\n"; + fprintf oc "%s:\n" profiling_write_table; + print_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name; + declare_function oc profiling_write_table; + match finalizer_call_method with + | Dtors -> + fprintf oc " .section %s\n" dtor_section; + write_symbol_pointer oc profiling_write_table + | Init_atexit(atexit_call) -> + fprintf oc " .section %s\n" init_section; + write_symbol_pointer oc profiling_init; + fprintf oc " .text\n"; + fprintf oc "%s:\n" profiling_init; + atexit_call oc profiling_write_table; + declare_function oc profiling_init + end;; let profiling_offset id kind = ((profiling_position id)*2 + kind)*8;; diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index 0ba739c2..f8fc5d6b 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -1,25 +1,35 @@ open Camlcoq open RTL - +open Maps + type identifier = Digest.t - -let function_id (f : coq_function) : identifier = - Digest.string (Marshal.to_string f []);; - -let branch_id (f_id : identifier) (node : P.t) : identifier = - Digest.string (f_id ^ (Int64.to_string (P.to_int64 node)));; let pp_id channel (x : identifier) = + assert(String.length x = 16); for i=0 to 15 do Printf.fprintf channel "%02x" (Char.code (String.get x i)) done -let spp_id () (x : identifier) : string = - let s = ref "" in - for i=0 to 15 do - s := Printf.sprintf "%02x%s" (Char.code (String.get x i)) !s - done; - !s;; +let print_anonymous_function pp f = + let instrs = + List.sort + (fun (pc1, _) (pc2, _) -> compare pc2 pc1) + (List.rev_map + (fun (pc, i) -> (P.to_int pc, i)) + (PTree.elements f.fn_code)) in + PrintRTL.print_succ pp f.fn_entrypoint + (match instrs with (pc1, _) :: _ -> pc1 | [] -> -1); + List.iter (PrintRTL.print_instruction pp) instrs; + Printf.fprintf pp "}\n\n" + +let function_id (f : coq_function) : identifier = + let digest = Digest.string (Marshal.to_string f []) in + Printf.fprintf stderr "FUNCTION hash = %a\n" pp_id digest; + print_anonymous_function stderr f; + digest + +let branch_id (f_id : identifier) (node : P.t) : identifier = + Digest.string (f_id ^ (Int64.to_string (P.to_int64 node)));; let profiling_counts : (identifier, (Int64.t*Int64.t)) Hashtbl.t = Hashtbl.create 1000;; @@ -55,7 +65,7 @@ let load_profiling_info (filename : string) : unit = let condition_oracle (id : identifier) : bool option = let (count0, count1) = get_counts id in - (if count0 <> 0L || count1 <> 0L then + ( (* if count0 <> 0L || count1 <> 0L then *) Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1); if count0 = count1 then None else Some(count1 > count0);; diff --git a/common/PrintAST.ml b/common/PrintAST.ml index e24607ee..38bbfa47 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -47,6 +47,13 @@ let name_of_chunk = function | Many32 -> "any32" | Many64 -> "any64" +let spp_profiling_id () (x : Digest.t) : string = + let s = Buffer.create 32 in + for i=0 to 15 do + Printf.bprintf s "%02x" (Char.code (String.get x i)) + done; + Buffer.contents s;; + let name_of_external = function | EF_external(name, sg) -> sprintf "extern %S" (camlstring_of_coqstring name) | EF_builtin(name, sg) -> sprintf "builtin %S" (camlstring_of_coqstring name) @@ -63,7 +70,7 @@ let name_of_external = function | EF_debug(kind, text, targs) -> sprintf "debug%d %S" (P.to_int kind) (extern_atom text) | EF_profiling(id, kind) -> - sprintf "profiling %a %d" Profilingaux.spp_id id (Z.to_int kind) + sprintf "profiling %a %d" spp_profiling_id id (Z.to_int kind) let rec print_builtin_arg px oc = function | BA x -> px oc x diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index e66db1db..85e5c246 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -3,17 +3,17 @@ CFILES=main.c solver.c clock.c CCOMP=../../../ccomp -GCC=aarch64-linux-gnu-gcc -#GCC=k1-cos-gcc -EXECUTE=qemu-aarch64 +#GCC=aarch64-linux-gnu-gcc +GCC=k1-cos-gcc +#EXECUTE=qemu-aarch64 #EXECUTE=qemu-arm -#EXECUTE=k1-cluster -- +EXECUTE=k1-cluster -- EXECUTE_CYCLES=k1-cluster --cycle-based -- LIBS=-lm PROFILING_DAT=compcert_profiling.dat EXAMPLE=sudoku.sat -CCOMPFLAGS=-finline-auto-threshold 50 -static -finline-asm +CCOMPFLAGS=-static -finline-asm -finline-auto-threshold 50 GCCFLAGS=-static ALL=minisat.ccomp.log minisat.ccomp.trace-linearize.log minisat.ccomp.profiled.log minisat.gcc-O3.log minisat.gcc-O3.profiled.log -- cgit From 2d1a27eb606fd5effd260d32545e10eaf90cf19c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 00:20:16 +0200 Subject: otherwise timings disabled on arm (ccomp should call preprocessor with appropriate options) --- test/monniaux/cycles.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index 36de6cc5..5011b18c 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -45,7 +45,7 @@ static inline cycle_t get_cycle(void) { return cycles; } -#elif defined (__ARM_ARCH) && (__ARM_ARCH >= 6) +#elif defined (__ARM_ARCH) // && (__ARM_ARCH >= 6) #if (__ARM_ARCH < 8) typedef uint32_t cycle_t; #define PRcycle PRId32 -- cgit From 40cd35c9152ceba673e255ee1d6108e224a54c3f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 08:09:23 +0200 Subject: x86-64 profiling --- test/monniaux/minisat/Makefile.profiled | 8 ++--- x86/Asmexpand.ml | 2 +- x86/TargetPrinter.ml | 63 +++++++++++++++++++++++++++++++-- 3 files changed, 65 insertions(+), 8 deletions(-) diff --git a/test/monniaux/minisat/Makefile.profiled b/test/monniaux/minisat/Makefile.profiled index 85e5c246..77ba8b43 100644 --- a/test/monniaux/minisat/Makefile.profiled +++ b/test/monniaux/minisat/Makefile.profiled @@ -7,8 +7,8 @@ CCOMP=../../../ccomp GCC=k1-cos-gcc #EXECUTE=qemu-aarch64 #EXECUTE=qemu-arm -EXECUTE=k1-cluster -- -EXECUTE_CYCLES=k1-cluster --cycle-based -- +#EXECUTE=k1-cluster -- +#EXECUTE_CYCLES=k1-cluster --cycle-based -- LIBS=-lm PROFILING_DAT=compcert_profiling.dat @@ -36,7 +36,7 @@ minisat.gcc-O3.profile-arcs.exe: main.c solver.c clock.gcc-O3.noprofile.o $(GCC) -DARM_NO_PRIVILEGE $(GCCFLAGS) -fprofile-arcs -O3 $+ -o $@ $(LIBS) gcda: minisat.gcc-O3.profile-arcs.exe - $(EXECUTE) $< $(EXAMPLE) + $(EXECUTE) ./$< $(EXAMPLE) main.gcda solver.gcda: gcda @@ -48,7 +48,7 @@ minisat.ccomp.trace-linearize.exe: $(CFILES) $(PROFILING_DAT): minisat.ccomp.profile-arcs.exe -rm -f $(PROFILING_DAT) - $(EXECUTE) $< $(EXAMPLE) + $(EXECUTE) ./$< $(EXAMPLE) minisat.ccomp.profiled.exe: $(CFILES) $(PROFILING_DAT) $(CCOMP) $(CCOMPFLAGS) -fprofile-use= $(PROFILING_DAT) -ftracelinearize $(CFILES) -o $@ $(LIBS) diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index b8353046..ad667e3d 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -552,7 +552,7 @@ let expand_instruction instr = expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args | EF_annot_val(kind,txt, targ) -> expand_annot_val kind txt targ args res - | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + | EF_annot _ | EF_debug _ | EF_inline_asm _ | EF_profiling _ -> emit instr | _ -> assert false diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 6159437e..3ffad3d0 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -165,7 +165,42 @@ module ELF_System : SYSTEM = let print_var_info = elf_print_var_info - let print_epilogue _ = () + let print_atexit oc to_be_called = + if Archi.ptr64 + then + begin + fprintf oc " leaq %s(%%rip), %%rdi\n" to_be_called; + fprintf oc " jmp atexit\n" + end + else + begin + fprintf oc " pushl $%s\n" to_be_called; + fprintf oc " call atexit\n"; + fprintf oc " addl $4, %%esp\n" + end + + let x86_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name = + if Archi.ptr64 + then + begin + fprintf oc " leaq %s(%%rip), %%rdx\n" profiling_counter_table_name; + fprintf oc " leaq %s(%%rip), %%rsi\n" profiling_id_table_name; + fprintf oc " movl $%d, %%edi\n" nr_items; + fprintf oc " jmp %s\n" profiling_write_table_helper + end + else + begin + fprintf oc " pushl $%s\n" profiling_counter_table_name; + fprintf oc " pushl $%s\n" profiling_id_table_name; + fprintf oc " pushl $%d\n" nr_items; + fprintf oc " call %s\n" profiling_write_table_helper ; + fprintf oc " addl $12, %%esp\n" + end;; + + let print_epilogue oc = + print_profiling_epilogue elf_text_print_fun_info (Init_atexit print_atexit) x86_profiling_stub oc;; let print_comm_decl oc name sz al = fprintf oc " .comm %a, %s, %d\n" symbol name (Z.to_string sz) al @@ -395,8 +430,28 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%a(%%rip)" label lbl end - - + let print_profiling_logger oc id kind = + assert (kind >= 0); + assert (kind <= 1); + let ofs = profiling_offset id kind in + if Archi.ptr64 + then + begin + fprintf oc "%s profiling %a %d: atomic increment\n" comment + Profilingaux.pp_id id kind; + fprintf oc " lock addq $1, %s+%d(%%rip)\n" + profiling_counter_table_name ofs + end + else + begin + fprintf oc "%s begin profiling %a %d: increment\n" comment + Profilingaux.pp_id id kind; + fprintf oc " addl $1, %s+%d\n" profiling_counter_table_name ofs; + fprintf oc " adcl $1, %s+%d\n" profiling_counter_table_name (ofs+4); + fprintf oc "%s end profiling %a %d: increment\n" comment + Profilingaux.pp_id id kind; + end + (* Printing of instructions *) (* Reminder on X86 assembly syntaxes: @@ -834,6 +889,8 @@ module Target(System: SYSTEM):TARGET = fprintf oc "%s begin inline assembly\n\t" comment; print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; fprintf oc "%s end inline assembly\n" comment + | EF_profiling(id, coq_kind) -> + print_profiling_logger oc id (Z.to_int coq_kind) | _ -> assert false end -- cgit From 8bbb1bbaad236901afea1cbb7033dcc097e7b94e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 08:30:14 +0200 Subject: fix IA32 profiling bug --- x86/TargetPrinter.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml index 3ffad3d0..b690c817 100644 --- a/x86/TargetPrinter.ml +++ b/x86/TargetPrinter.ml @@ -176,7 +176,8 @@ module ELF_System : SYSTEM = begin fprintf oc " pushl $%s\n" to_be_called; fprintf oc " call atexit\n"; - fprintf oc " addl $4, %%esp\n" + fprintf oc " addl $4, %%esp\n"; + fprintf oc " ret\n" end let x86_profiling_stub oc nr_items @@ -196,7 +197,8 @@ module ELF_System : SYSTEM = fprintf oc " pushl $%s\n" profiling_id_table_name; fprintf oc " pushl $%d\n" nr_items; fprintf oc " call %s\n" profiling_write_table_helper ; - fprintf oc " addl $12, %%esp\n" + fprintf oc " addl $12, %%esp\n"; + fprintf oc " ret\n" end;; let print_epilogue oc = -- cgit From d48af10f5a2ef06b518e86398d504706e4995e09 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 09:05:26 +0200 Subject: now use COMPCERT_PROFILING_DATA and don't print stuff --- runtime/c/write_profiling_table.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 60bae3d7..0ce7a948 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -1,5 +1,6 @@ #include #include +#include #include typedef uint8_t md5_hash[16]; @@ -25,8 +26,15 @@ void _compcert_write_profiling_table(unsigned int nr_items, md5_hash id_table[], condition_counters counter_table[]) { errno = 0; + + const char *filename = getenv("COMPCERT_PROFILING_DATA"); + if (filename) { + if (!*filename) return; + } else { + filename = "compcert_profiling.dat"; + } - FILE *fp = fopen("compcert_profiling.dat", "a"); + FILE *fp = fopen(filename, "a"); //fprintf(stderr, "successfully opened profiling file\n"); if (fp == NULL) { perror("open CompCert profiling data for writing"); @@ -46,5 +54,5 @@ void _compcert_write_profiling_table(unsigned int nr_items, perror("write CompCert profiling data"); return; } - fprintf(stderr, "write CompCert profiling data: no error\n"); + // fprintf(stderr, "write CompCert profiling data: no error\n"); } -- cgit From 08463f9eb77b9b2eacce7b0c5881a1bdde203d7f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 10:09:57 +0200 Subject: instructions --- PROFILING.md | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 PROFILING.md diff --git a/PROFILING.md b/PROFILING.md new file mode 100644 index 00000000..4a44d8eb --- /dev/null +++ b/PROFILING.md @@ -0,0 +1,30 @@ +This version of CompCert includes a profiling system. It tells CompCert's optimization phases for each conditional branch instruction which of the two branches was more frequently taken. This system is not available for all combinations of target architecture and operating system; see below. + +For using this profiling system one has to +1. Compile a special version of the program that will count, for each branch, the number of times it was taken, and recording this information to a file. +2. Execute this special version on representative examples. It will record the frequencies of execution of branches to a log file. +3. Recompile the program, telling CompCert to use the information in the log file. + +This system does not use the same formats as gcc's gcov profiles, since it depends heavily on compiler internals. It seems however possible to profile and optimize programs consisting of modules compiled with gcc and CompCert by using both system simultaneously: compiler uses separate log files. + +To compile the special version that logs frequencies to files, use the option `-fprofile-arcs`. This option has to be specified at compile time but is not needed at link time (however, a reminder: if you link using another compiled than CompCert, you need to link against `libcompcert.a`). You may mix object files compiled with and without this option. + +This version may experience significant slowdown compared to normally compiled code, so do not use `-fprofile-arcs` for production code. + +At the end of execution of the program, frequency information will be logged to a file whose default name is `compcert_profiling.dat` (in the current directory). Another name may be used by specifying it using the `COMPCERT_PROFILING_DATA` environment variable. If this variable contains an empty string, no logging is done (but the slowdown still applies). + +Depending on the platform, this logging system is or is not thread-safe and is or is not compatible with position-independent code (PIC). In non thread-safe configurations, if two different execution threads execute code to be profiled, the profiling counters may end up with incorrect values. + +| Target platform | Available? | Thread-safe | PIC | +|-----------------|------------|-------------|-----| +| AArch64 | Yes | Yes | No | +| ARM | Yes | No | No | +| IA32 | Yes | No | No | +| K1c | Yes | Yes | No | +| PowerPC | No | | | +| PowerPC 64 | No | | | +| Risc-V 32 | No | | | +| Risc-V 64 | No | | | +| x86-64 | Yes | Yes | Yes | + +For recompiling the program using profiling information, use `-fprofile-use compcert_profiling.dat -ftracelinearize` (substitute the appropriate filename for `compcert_profiling.dat` if needed). Experiments show performance improvement on K1c, not on other platforms. -- cgit From 9e7f5e5611c5b5281b74b075b4524aef7bc05437 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 12 Apr 2020 12:03:42 +0200 Subject: profiling instructions --- PROFILING.md | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/PROFILING.md b/PROFILING.md index 4a44d8eb..3f4cbc46 100644 --- a/PROFILING.md +++ b/PROFILING.md @@ -13,6 +13,8 @@ This version may experience significant slowdown compared to normally compiled c At the end of execution of the program, frequency information will be logged to a file whose default name is `compcert_profiling.dat` (in the current directory). Another name may be used by specifying it using the `COMPCERT_PROFILING_DATA` environment variable. If this variable contains an empty string, no logging is done (but the slowdown still applies). +Data are appended to the log file, never deleted, so it is safe to run the program several times on several test cases to accumulate data. + Depending on the platform, this logging system is or is not thread-safe and is or is not compatible with position-independent code (PIC). In non thread-safe configurations, if two different execution threads execute code to be profiled, the profiling counters may end up with incorrect values. | Target platform | Available? | Thread-safe | PIC | @@ -27,4 +29,6 @@ Depending on the platform, this logging system is or is not thread-safe and is o | Risc-V 64 | No | | | | x86-64 | Yes | Yes | Yes | -For recompiling the program using profiling information, use `-fprofile-use compcert_profiling.dat -ftracelinearize` (substitute the appropriate filename for `compcert_profiling.dat` if needed). Experiments show performance improvement on K1c, not on other platforms. +For recompiling the program using profiling information, use `-fprofile-use= compcert_profiling.dat -ftracelinearize` (substitute the appropriate filename for `compcert_profiling.dat` if needed). Experiments show performance improvement on K1c, not on other platforms. + +The same options (except for `-fprofile-use=` and `-fprofile-arcs`) should be used to compile the logging and optimized versions of the program: only functions that are exactly the same in the intermediate representation will be optimized according to profiling information. -- cgit From 0c9cc34f2306b3ea073684806118f1ab36cfc993 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 13 Apr 2020 10:33:02 +0200 Subject: bump Coq version --- .gitlab-ci.yml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 069b9012..1f854fc3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,7 +3,7 @@ stages: check-admitted: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda - eval `opam config env` @@ -22,7 +22,7 @@ check-admitted: build_x86_64: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda - eval `opam config env` @@ -43,7 +43,7 @@ build_x86_64: build_ia32: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-multilib @@ -66,7 +66,7 @@ build_ia32: build_aarch64: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user @@ -89,7 +89,7 @@ build_aarch64: build_arm: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user @@ -113,7 +113,7 @@ build_arm: build_armhf: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user @@ -136,7 +136,7 @@ build_armhf: build_ppc: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user @@ -157,7 +157,7 @@ build_ppc: build_ppc64: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-powerpc64-linux-gnu @@ -178,7 +178,7 @@ build_ppc64: build_rv64: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -201,7 +201,7 @@ build_rv64: build_rv32: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user @@ -222,7 +222,7 @@ build_rv32: build_k1c: stage: build - image: "coqorg/coq:8.10" + image: "coqorg/coq" before_script: - opam switch 4.07.1+flambda - eval `opam config env` -- cgit From 5450d5054dc84d31c820b6d60c87c628290d5487 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Wed, 15 Apr 2020 11:11:05 +0200 Subject: Coq error message update in configure --- configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure b/configure index cb2f52ba..366ab847 100755 --- a/configure +++ b/configure @@ -575,7 +575,7 @@ case "$coq_ver" in if $ignore_coq_version; then echo "Warning: this version of Coq is unsupported, proceed at your own risks." else - echo "Error: CompCert requires one of the following Coq versions: 8.11.0, 8.10.2, 8.10.1, 8.10.0, 8.9.1, 8.9.0, 8.8.2, 8.8.1, 8.8.0" + echo "Error: CompCert requires one of the following Coq versions: 8.11.1, 8.11.0, 8.10.2, 8.10.1, 8.10.0, 8.9.1, 8.9.0" missingtools=true fi;; "") -- cgit From ba32e5daa1ff343a1a0b89e65c2ba5764c9cef04 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 14:10:51 +0200 Subject: progress on CSE2 builtins --- backend/CSE2.v | 31 +++++-------------------------- backend/CSE2proof.v | 20 +++++++++++++++----- 2 files changed, 20 insertions(+), 31 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index 900a7517..e2ab9f07 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -375,33 +375,12 @@ Definition load (chunk: memory_chunk) (addr : addressing) | None => load1 chunk addr dst args rel end. -(* NO LONGER NEEDED -Fixpoint list_represents { X : Type } (l : list (positive*X)) (tr : PTree.t X) : Prop := - match l with - | nil => True - | (r,sv)::tail => (tr ! r) = Some sv /\ list_represents tail tr +Fixpoint kill_builtin_res res rel := + match res with + | BR r => kill_reg r rel + | _ => rel end. -Lemma elements_represent : - forall { X : Type }, - forall tr : (PTree.t X), - (list_represents (PTree.elements tr) tr). -Proof. - intros. - generalize (PTree.elements_complete tr). - generalize (PTree.elements tr). - induction l; simpl; trivial. - intro COMPLETE. - destruct a as [ r sv ]. - split. - { - apply COMPLETE. - left; reflexivity. - } - apply IHl; auto. -Qed. -*) - Definition apply_instr instr (rel : RELATION.t) : RB.t := match instr with | Inop _ @@ -411,7 +390,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Iop op args dst _ => Some (gen_oper op dst args rel) | Iload trap chunk addr args dst _ => Some (load chunk addr dst args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) - | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) + | Ibuiltin _ _ res _ => Some (kill_builtin_res res (kill_mem rel)) | Itailcall _ _ _ | Ireturn _ => RB.bot end. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 309ccce1..e61cde3d 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1033,7 +1033,16 @@ Proof. assumption. } intuition congruence. -Qed. +Qed. + +Lemma kill_builtin_res_sound: + forall res (m : mem) (rs : regset) vres (rel : RELATION.t) + (REL : sem_rel m rel rs), + (sem_rel m (kill_builtin_res res rel) (regmap_setres res vres rs)). +Proof. + destruct res; simpl; intros; trivial. + apply kill_reg_sound; trivial. +Qed. End SOUNDNESS. Definition match_prog (p tp: RTL.program) := @@ -1578,9 +1587,9 @@ Proof. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply sem_rel_b_ge with (rb2 := Some RELATION.top). + apply sem_rel_b_ge with (rb2 := Some (kill_builtin_res res (kill_mem mpc))). { - replace (Some RELATION.top) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (kill_builtin_res res (kill_mem mpc))) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. 2: apply apply_instr'_bot. @@ -1591,8 +1600,9 @@ Proof. rewrite MPC. reflexivity. } - apply top_ok. - + apply kill_builtin_res_sound. + apply kill_mem_sound with (m := m). + assumption. (* cond *) - econstructor; split. -- cgit From b3431b1d9ee5121883d307cff0b62b7e53369891 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 15:29:24 +0200 Subject: refine the rules for builtins --- backend/CSE2.v | 19 ++++++++++++++++++- backend/CSE2proof.v | 23 +++++++++++++++++++---- 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index e2ab9f07..d9fe5799 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -381,6 +381,23 @@ Fixpoint kill_builtin_res res rel := | _ => rel end. +Definition apply_external_call ef (rel : RELATION.t) : RELATION.t := + match ef with + | EF_builtin name sg + | EF_runtime name sg => + match Builtins.lookup_builtin_function name sg with + | Some bf => rel + | None => kill_mem rel + end + | EF_malloc (* FIXME *) + | EF_external _ _ + | EF_vstore _ + | EF_free (* FIXME *) + | EF_memcpy _ _ (* FIXME *) + | EF_inline_asm _ _ _ => kill_mem rel + | _ => rel + end. + Definition apply_instr instr (rel : RELATION.t) : RB.t := match instr with | Inop _ @@ -390,7 +407,7 @@ Definition apply_instr instr (rel : RELATION.t) : RB.t := | Iop op args dst _ => Some (gen_oper op dst args rel) | Iload trap chunk addr args dst _ => Some (load chunk addr dst args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) - | Ibuiltin _ _ res _ => Some (kill_builtin_res res (kill_mem rel)) + | Ibuiltin ef _ res _ => Some (kill_builtin_res res (apply_external_call ef rel)) | Itailcall _ _ _ | Ireturn _ => RB.bot end. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index e61cde3d..9e0ad909 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1125,6 +1125,22 @@ Definition is_killed_in_fmap fmap pc res := | Some map => is_killed_in_map map pc res end. +Lemma external_call_sound: + forall ef (rel : RELATION.t) sp (m m' : mem) (rs : regset) vargs t vres + (REL : sem_rel fundef unit ge sp m rel rs) + (CALL : external_call ef ge vargs m t vres m'), + sem_rel fundef unit ge sp m' (apply_external_call ef rel) rs. +Proof. + destruct ef; intros; simpl in *. + all: eauto using kill_mem_sound. + all: unfold builtin_or_external_sem in *. + 1, 2: destruct (Builtins.lookup_builtin_function name sg); + eauto using kill_mem_sound; + inv CALL; eauto using kill_mem_sound. + all: inv CALL. + all: eauto using kill_mem_sound. +Qed. + Definition sem_rel_b' := sem_rel_b fundef unit ge. Definition fmap_sem' := fmap_sem fundef unit ge. Definition subst_arg_ok' := subst_arg_ok fundef unit ge. @@ -1587,9 +1603,9 @@ Proof. destruct (forward_map _) as [map |] eqn:MAP in *; trivial. destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction. - apply sem_rel_b_ge with (rb2 := Some (kill_builtin_res res (kill_mem mpc))). + apply sem_rel_b_ge with (rb2 := Some (kill_builtin_res res (apply_external_call ef mpc))). { - replace (Some (kill_builtin_res res (kill_mem mpc))) with (apply_instr' (fn_code f) pc (map # pc)). + replace (Some (kill_builtin_res res (apply_external_call ef mpc))) with (apply_instr' (fn_code f) pc (map # pc)). { eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption. 2: apply apply_instr'_bot. @@ -1601,8 +1617,7 @@ Proof. reflexivity. } apply kill_builtin_res_sound. - apply kill_mem_sound with (m := m). - assumption. + eapply external_call_sound with (m := m); eassumption. (* cond *) - econstructor; split. -- cgit From 60e4ad85c6cd433c9e28c9e407a957ca3a302c22 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 18:00:14 +0200 Subject: CSE3: better builtin handling --- backend/CSE2.v | 2 +- backend/CSE3analysis.v | 25 ++++++++++++++++++++++++- backend/CSE3analysisproof.v | 30 ++++++++++++++++++++++++++++++ backend/CSE3proof.v | 8 +++++--- 4 files changed, 60 insertions(+), 5 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index cad740ba..8e2307b0 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -262,7 +262,7 @@ Definition load (chunk: memory_chunk) (addr : addressing) | None => load1 chunk addr dst args rel end. -Fixpoint kill_builtin_res res rel := +Definition kill_builtin_res res rel := match res with | BR r => kill_reg r rel | _ => rel diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 90ce4ce7..bc5d3244 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -325,6 +325,29 @@ Section OPERATIONS. (rel : RELATION.t) : RELATION.t := store1 chunk addr (forward_move_l rel args) src ty rel. + Definition kill_builtin_res res rel := + match res with + | BR r => kill_reg r rel + | _ => rel + end. + + Definition apply_external_call ef (rel : RELATION.t) : RELATION.t := + match ef with + | EF_builtin name sg + | EF_runtime name sg => + match Builtins.lookup_builtin_function name sg with + | Some bf => rel + | None => kill_mem rel + end + | EF_malloc (* FIXME *) + | EF_external _ _ + | EF_vstore _ + | EF_free (* FIXME *) + | EF_memcpy _ _ (* FIXME *) + | EF_inline_asm _ _ _ => kill_mem rel + | _ => rel + end. + Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := match instr with | Inop _ @@ -335,7 +358,7 @@ Section OPERATIONS. | Iop op args dst _ => Some (oper dst (SOp op) args rel) | Iload trap chunk addr args dst _ => Some (oper dst (SLoad chunk addr) args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) - | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *) + | Ibuiltin ef _ res _ => Some (kill_builtin_res res (apply_external_call ef rel)) | Itailcall _ _ _ | Ireturn _ => RB.bot end. End PER_NODE. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index b87ec92c..f4ec7a10 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -869,6 +869,36 @@ Section SOUNDNESS. Hint Resolve store_sound : cse3. + Lemma kill_builtin_res_sound: + forall res (m : mem) (rs : regset) vres (rel : RELATION.t) + (REL : sem_rel rel rs m), + (sem_rel (kill_builtin_res (ctx:=ctx) res rel) + (regmap_setres res vres rs) m). + Proof. + destruct res; simpl; intros; trivial. + apply kill_reg_sound; trivial. + Qed. + + Hint Resolve kill_builtin_res_sound : cse3. + + Lemma external_call_sound: + forall ge ef (rel : RELATION.t) (m m' : mem) (rs : regset) vargs t vres + (REL : sem_rel rel rs m) + (CALL : external_call ef ge vargs m t vres m'), + sem_rel (apply_external_call (ctx:=ctx) ef rel) rs m'. + Proof. + destruct ef; intros; simpl in *. + all: eauto using kill_mem_sound. + all: unfold builtin_or_external_sem in *. + 1, 2: destruct (Builtins.lookup_builtin_function name sg); + eauto using kill_mem_sound; + inv CALL; eauto using kill_mem_sound. + all: inv CALL. + all: eauto using kill_mem_sound. + Qed. + + Hint Resolve external_call_sound : cse3. + Section INDUCTIVENESS. Variable fn : RTL.function. Variable tenv : typing_env. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 19fb20be..53872e62 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -224,7 +224,6 @@ Proof. eapply function_ptr_translated; eauto. Qed. -Check sem_rel_b. Inductive match_stackframes: list stackframe -> list stackframe -> signature -> Prop := | match_stackframes_nil: forall sg, sg.(sig_res) = Tint -> @@ -428,8 +427,8 @@ Ltac IND_STEP := destruct ((fst (preanalysis tenv fn)) # mpc) as [zinv | ]; simpl in *; intuition; - eapply rel_ge; eauto with cse3; - idtac mpc mpc' fn minstr + eapply rel_ge; eauto with cse3 (* ; for printing + idtac mpc mpc' fn minstr *) end. Lemma if_same : forall {T : Type} (b : bool) (x : T), @@ -753,6 +752,9 @@ Proof. + econstructor; eauto. * eapply wt_exec_Ibuiltin with (f:=f); eauto with wt. * IND_STEP. + apply kill_builtin_res_sound; eauto with cse3. + eapply external_call_sound; eauto with cse3. + - (* Icond *) econstructor. split. + eapply exec_Icond with (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); try eassumption. -- cgit From 6ae48a2f079d6c420df57cb8616692c3d6cdd0ca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 18:01:25 +0200 Subject: adapt for Icond with predicted direction --- backend/CSE3.v | 4 ++-- backend/CSE3analysis.v | 2 +- backend/Inject.v | 4 ++-- backend/Injectproof.v | 16 ++++++++-------- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index d0dc3aef..352cc895 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -62,8 +62,8 @@ Definition transf_instr (fmap : PMap.t RB.t) Icall sig ros (subst_args fmap pc args) dst s | Itailcall sig ros args => Itailcall sig ros (subst_args fmap pc args) - | Icond cond args s1 s2 => - Icond cond (subst_args fmap pc args) s1 s2 + | Icond cond args s1 s2 expected => + Icond cond (subst_args fmap pc args) s1 s2 expected | Ijumptable arg tbl => Ijumptable (subst_arg fmap pc arg) tbl | Ireturn (Some arg) => diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 12fb2d1f..90ce4ce7 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -328,7 +328,7 @@ Section OPERATIONS. Definition apply_instr (tenv : typing_env) (instr : RTL.instruction) (rel : RELATION.t) : RB.t := match instr with | Inop _ - | Icond _ _ _ _ + | Icond _ _ _ _ _ | Ijumptable _ _ => Some rel | Istore chunk addr args src _ => Some (store chunk addr args src (tenv src) rel) diff --git a/backend/Inject.v b/backend/Inject.v index 2350c149..971a5423 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -34,7 +34,7 @@ Definition successor (i : instruction) : node := | Istore _ _ _ _ pc' => pc' | Icall _ _ _ _ pc' => pc' | Ibuiltin _ _ _ pc' => pc' - | Icond _ _ pc' _ => pc' + | Icond _ _ pc' _ _ => pc' | Itailcall _ _ _ | Ijumptable _ _ | Ireturn _ => 1 @@ -47,7 +47,7 @@ Definition alter_successor (i : instruction) (pc' : node) : instruction := | Iload trap chunk addr args dst _ => Iload trap chunk addr args dst pc' | Istore chunk addr args src _ => Istore chunk addr args src pc' | Ibuiltin ef args res _ => Ibuiltin ef args res pc' - | Icond cond args _ pc2 => Icond cond args pc' pc2 + | Icond cond args _ pc2 expected => Icond cond args pc' pc2 expected | Icall sig ros args res _ => Icall sig ros args res pc' | Itailcall _ _ _ | Ijumptable _ _ diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 2506bcc8..75fed25f 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1651,9 +1651,9 @@ Section INJECTOR. destruct SKIP as [trs' [MATCH PLUS]]. econstructor; split. * eapply Smallstep.plus_left. - ** apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot). + ** apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot) (predb := predb). exact ALTER. - replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + replace args with (instr_uses (Icond cond args ifso ifnot predb)) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. simpl. reflexivity. ** apply Smallstep.plus_star. @@ -1669,28 +1669,28 @@ Section INJECTOR. destruct SKIP as [trs' [MATCH PLUS]]. econstructor; split. * eapply Smallstep.plus_one. - apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot). + apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := pc_inj) (ifnot := ifnot) (predb := predb). exact ALTER. - replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + replace args with (instr_uses (Icond cond args ifso ifnot predb)) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. simpl. reflexivity. * simpl. constructor; auto. + destruct b eqn:B. * econstructor; split. ** eapply Smallstep.plus_one. - apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot). + apply exec_Icond with (b := true) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot) (predb := predb). *** rewrite transf_function_preserves with (f:=f); eauto. eapply max_pc_function_sound; eauto. - *** replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + *** replace args with (instr_uses (Icond cond args ifso ifnot predb)) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. *** reflexivity. ** constructor; auto. * econstructor; split. ** eapply Smallstep.plus_one. - apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot). + apply exec_Icond with (b := false) (cond := cond) (args := args) (ifso := ifso) (ifnot := ifnot) (predb := predb). *** rewrite transf_function_preserves with (f:=f); eauto. eapply max_pc_function_sound; eauto. - *** replace args with (instr_uses (Icond cond args ifso ifnot)) by reflexivity. + *** replace args with (instr_uses (Icond cond args ifso ifnot predb)) by reflexivity. rewrite transf_function_preserves_uses with (f := f) (tf := tf) (pc := pc) (rs := rs); trivial. *** reflexivity. ** constructor; auto. -- cgit From 931b424732474cef10858af4959af6f53a082581 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 20:34:23 +0200 Subject: begin HashedMaps --- lib/HashedMap.v | 332 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 332 insertions(+) create mode 100644 lib/HashedMap.v diff --git a/lib/HashedMap.v b/lib/HashedMap.v new file mode 100644 index 00000000..baeb524c --- /dev/null +++ b/lib/HashedMap.v @@ -0,0 +1,332 @@ +Require Import ZArith. +Require Import Bool. +Require Import List. +Require Coq.Logic.Eqdep_dec. + +(* begin from Maps *) +Fixpoint prev_append (i j: positive) {struct i} : positive := + match i with + | xH => j + | xI i' => prev_append i' (xI j) + | xO i' => prev_append i' (xO j) + end. + +Definition prev (i: positive) : positive := + prev_append i xH. + +Lemma prev_append_prev i j: + prev (prev_append i j) = prev_append j i. +Proof. + revert j. unfold prev. + induction i as [i IH|i IH|]. 3: reflexivity. + intros j. simpl. rewrite IH. reflexivity. + intros j. simpl. rewrite IH. reflexivity. +Qed. + +Lemma prev_involutive i : + prev (prev i) = i. +Proof (prev_append_prev i xH). + +Lemma prev_append_inj i j j' : + prev_append i j = prev_append i j' -> j = j'. +Proof. + revert j j'. + induction i as [i Hi|i Hi|]; intros j j' H; auto; + specialize (Hi _ _ H); congruence. +Qed. + +(* end from Maps *) + +Lemma orb_idem: forall b, orb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_idem: forall b, andb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_negb_false: forall b, andb b (negb b) = false. +Proof. + destruct b; reflexivity. +Qed. + +Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false : pmap. + +Parameter T : Type. +Parameter T_eq_dec : forall (x y : T), {x = y} + {x <> y}. + +Inductive pmap : Type := +| Empty : pmap +| Node : pmap -> option T -> pmap -> pmap. +Definition empty := Empty. + +Definition is_empty x := + match x with + | Empty => true + | Node _ _ _ => false + end. + +Definition is_some (x : option T) := + match x with + | Some _ => true + | None => false + end. + +Fixpoint wf x := + match x with + | Empty => true + | Node b0 f b1 => + (wf b0) && (wf b1) && + ((negb (is_empty b0)) || (is_some f) || (negb (is_empty b1))) + end. + +Definition iswf x := (wf x)=true. + +Lemma empty_wf : iswf empty. +Proof. + reflexivity. +Qed. + +Definition pmap_eq : + forall s s': pmap, { s=s' } + { s <> s' }. +Proof. + generalize T_eq_dec. + induction s; destruct s'; repeat decide equality. +Qed. + +Fixpoint get (i : positive) (s : pmap) {struct i} : option T := + match s with + | Empty => None + | Node b0 f b1 => + match i with + | xH => f + | xO ii => get ii b0 + | xI ii => get ii b1 + end + end. + +Lemma gempty : + forall i : positive, + get i Empty = None. +Proof. + destruct i; simpl; reflexivity. +Qed. + +Hint Resolve gempty : pmap. +Hint Rewrite gempty : pmap. + +Definition node (b0 : pmap) (f : option T) (b1 : pmap) : pmap := + match b0, f, b1 with + | Empty, None, Empty => Empty + | _, _, _ => Node b0 f b1 + end. + +Lemma wf_node : + forall b0 f b1, + iswf b0 -> iswf b1 -> iswf (node b0 f b1). +Proof. + destruct b0; destruct f; destruct b1; simpl. + all: unfold iswf; simpl; intros; trivial. + all: autorewrite with pmap; trivial. + all: rewrite H. + all: rewrite H0. + all: reflexivity. +Qed. + +Hint Resolve wf_node: pmap. + +Lemma gnode : + forall b0 f b1 i, + get i (node b0 f b1) = + get i (Node b0 f b1). +Proof. + destruct b0; simpl; trivial. + destruct f; simpl; trivial. + destruct b1; simpl; trivial. + intro. + rewrite gempty. + destruct i; simpl; trivial. + all: symmetry; apply gempty. +Qed. + +Hint Rewrite gnode : pmap. + +Fixpoint set (i : positive) (j : T) (s : pmap) {struct i} : pmap := + match s with + | Empty => + match i with + | xH => Node Empty (Some j) Empty + | xO ii => Node (set ii j Empty) None Empty + | xI ii => Node Empty None (set ii j Empty) + end + | Node b0 f b1 => + match i with + | xH => Node b0 (Some j) b1 + | xO ii => Node (set ii j b0) f b1 + | xI ii => Node b0 f (set ii j b1) + end + end. + +Lemma set_nonempty: + forall i j s, is_empty (set i j s) = false. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Hint Rewrite set_nonempty : pmap. +Hint Resolve set_nonempty : pmap. + +Lemma wf_set: + forall i j s, (iswf s) -> (iswf (set i j s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: autorewrite with pmap; simpl; trivial. + 1,3: auto with pmap. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: intuition. +Qed. + +Hint Resolve wf_set : pset. + +Theorem gss : + forall (i : positive) (j : T) (s : pmap), + get i (set i j s) = Some j. +Proof. + induction i; destruct s; simpl; auto. +Qed. + +Hint Resolve gss : pmap. +Hint Rewrite gss : pmap. + +Theorem gso : + forall (i j : positive) (k : T) (s : pmap), + i <> j -> + get j (set i k s) = get j s. +Proof. + induction i; destruct j; destruct s; simpl; intro; auto with pmap. + 5, 6: congruence. + all: rewrite IHi by congruence. + all: trivial. + all: apply gempty. +Qed. + +Hint Resolve gso : pmap. + +Fixpoint remove (i : positive) (s : pmap) { struct i } : pmap := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 None b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => node (remove ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 f (remove ii b1) + end + end. + +Lemma wf_remove : + forall i s, (iswf s) -> (iswf (remove i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: apply wf_node. + all: intuition. + all: apply IHi. + all: assumption. +Qed. + +Fixpoint remove_noncanon (i : positive) (s : pmap) { struct i } : pmap := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 None b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node (remove_noncanon ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 f (remove_noncanon ii b1) + end + end. + +Lemma remove_noncanon_same: + forall i j s, (get j (remove i s)) = (get j (remove_noncanon i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: rewrite gnode. + 3: reflexivity. + all: destruct j; simpl; trivial. +Qed. + +Lemma remove_empty : + forall i, remove i Empty = Empty. +Proof. + induction i; simpl; trivial. +Qed. + +Hint Rewrite remove_empty : pmap. +Hint Resolve remove_empty : pmap. + +Lemma gremove_noncanon_s : + forall i : positive, + forall s : pmap, + get i (remove_noncanon i s) = None. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Theorem grs : + forall i : positive, + forall s : pmap, + get i (remove i s) = None. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_s. +Qed. + +Hint Resolve grs : pmap. +Hint Rewrite grs : pmap. + +Lemma gremove_noncanon_o : + forall i j : positive, + forall s : pmap, + i<>j -> + get j (remove_noncanon i s) = get j s. +Proof. + induction i; destruct j; destruct s; simpl; intro; trivial. + 1, 2: rewrite IHi by congruence. + 1, 2: reflexivity. + congruence. +Qed. + +Theorem gro : + forall (i j : positive) (s : pmap), + i<>j -> + get j (remove i s) = get j s. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_o. + assumption. +Qed. + +Hint Resolve gro : pmap. -- cgit From 0575b91176870ac5d1c5692d19059a12e4d9667c Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 22:23:11 +0200 Subject: gmap2_idem_Empty --- lib/HashedMap.v | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/lib/HashedMap.v b/lib/HashedMap.v index baeb524c..1baff1a1 100644 --- a/lib/HashedMap.v +++ b/lib/HashedMap.v @@ -330,3 +330,57 @@ Proof. Qed. Hint Resolve gro : pmap. + +Section MAP2_IDEM. + Variable f : option T -> option T -> option T. + Hypothesis f_idem : forall x, f x x = x. + + Fixpoint map2_idem_Empty (b : pmap) := + match b with + | Empty => Empty + | Node b0 bf b1 => + node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) + end. + + Lemma gmap2_idem_Empty: forall i b, + get i (map2_idem_Empty b) = f None (get i b). + Proof. + induction i; destruct b as [ | b0 bf b1]; intros; simpl in *. + all: try congruence. + - replace + (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with + | Empty => None + | Node _ _ c1 => get i c1 + end) + with (get (xI i) (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - replace + (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with + | Empty => None + | Node c0 _ _ => get i c0 + end) + with (get (xO i) (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - change (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with + | Empty => None + | Node _ cf _ => cf + end) with (get xH (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). + rewrite gnode. reflexivity. + Qed. + + Fixpoint map2_idem (a b : pmap) := + match a with + | Empty => map2_idem_Empty b + | (Node a0 af a1) => + match b with + | (Node b0 bf b1) => + node (map2_idem a0 b0) (f af bf) (map2_idem a1 b1) + | Empty => + node (map2_idem a0 Empty) (f af None) (map2_idem a1 Empty) + end + end. + -- cgit From 48ba6c006c966227b8a0b96ed48203af36835615 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 22:54:21 +0200 Subject: gmap2_idem --- lib/HashedMap.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/lib/HashedMap.v b/lib/HashedMap.v index 1baff1a1..21f35af8 100644 --- a/lib/HashedMap.v +++ b/lib/HashedMap.v @@ -384,3 +384,19 @@ Section MAP2_IDEM. end end. + Lemma gmap2_idem: forall a b i, + get i (map2_idem a b) = f (get i a) (get i b). + Proof. + induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. + { rewrite gmap2_idem_Empty. + rewrite gempty. + reflexivity. } + destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. + - destruct i; simpl. + + rewrite IHa1. rewrite gempty. + reflexivity. + + rewrite IHa0. rewrite gempty. + reflexivity. + + reflexivity. + - destruct i; simpl; congruence. + Qed. -- cgit From 33927b62b2d443ae3989b9565dac51070d9d8a86 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 23:14:50 +0200 Subject: gmap2_idem --- lib/HashedMap.v | 176 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 111 insertions(+), 65 deletions(-) diff --git a/lib/HashedMap.v b/lib/HashedMap.v index 21f35af8..df724867 100644 --- a/lib/HashedMap.v +++ b/lib/HashedMap.v @@ -331,72 +331,118 @@ Qed. Hint Resolve gro : pmap. -Section MAP2_IDEM. +Section MAP2. + Variable f : option T -> option T -> option T. - Hypothesis f_idem : forall x, f x x = x. - Fixpoint map2_idem_Empty (b : pmap) := - match b with - | Empty => Empty - | Node b0 bf b1 => - node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) - end. - - Lemma gmap2_idem_Empty: forall i b, - get i (map2_idem_Empty b) = f None (get i b). - Proof. - induction i; destruct b as [ | b0 bf b1]; intros; simpl in *. - all: try congruence. - - replace - (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with - | Empty => None - | Node _ _ c1 => get i c1 - end) - with (get (xI i) (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). - + rewrite gnode. - simpl. apply IHi. - + destruct node; auto with pmap. - - replace - (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with - | Empty => None - | Node c0 _ _ => get i c0 - end) - with (get (xO i) (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). - + rewrite gnode. - simpl. apply IHi. - + destruct node; auto with pmap. - - change (match node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1) with - | Empty => None - | Node _ cf _ => cf - end) with (get xH (node (map2_idem_Empty b0) (f None bf) (map2_idem_Empty b1))). - rewrite gnode. reflexivity. - Qed. - - Fixpoint map2_idem (a b : pmap) := - match a with - | Empty => map2_idem_Empty b - | (Node a0 af a1) => + Section NONE_NONE. + Hypothesis f_none_none : f None None = None. + + Fixpoint map2_Empty (b : pmap) := match b with - | (Node b0 bf b1) => - node (map2_idem a0 b0) (f af bf) (map2_idem a1 b1) - | Empty => - node (map2_idem a0 Empty) (f af None) (map2_idem a1 Empty) - end - end. + | Empty => Empty + | Node b0 bf b1 => + node (map2_Empty b0) (f None bf) (map2_Empty b1) + end. + + Lemma gmap2_Empty: forall i b, + get i (map2_Empty b) = f None (get i b). + Proof. + induction i; destruct b as [ | b0 bf b1]; intros; simpl in *. + all: try congruence. + - replace + (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node _ _ c1 => get i c1 + end) + with (get (xI i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - replace + (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node c0 _ _ => get i c0 + end) + with (get (xO i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - change (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node _ cf _ => cf + end) with (get xH (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + rewrite gnode. reflexivity. + Qed. + + Fixpoint map2 (a b : pmap) := + match a with + | Empty => map2_Empty b + | (Node a0 af a1) => + match b with + | (Node b0 bf b1) => + node (map2 a0 b0) (f af bf) (map2 a1 b1) + | Empty => + node (map2 a0 Empty) (f af None) (map2 a1 Empty) + end + end. - Lemma gmap2_idem: forall a b i, - get i (map2_idem a b) = f (get i a) (get i b). - Proof. - induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. - { rewrite gmap2_idem_Empty. - rewrite gempty. - reflexivity. } - destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. - - destruct i; simpl. - + rewrite IHa1. rewrite gempty. - reflexivity. - + rewrite IHa0. rewrite gempty. - reflexivity. - + reflexivity. - - destruct i; simpl; congruence. - Qed. + Lemma gmap2: forall a b i, + get i (map2 a b) = f (get i a) (get i b). + Proof. + induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. + { rewrite gmap2_Empty. + rewrite gempty. + reflexivity. } + destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. + - destruct i; simpl. + + rewrite IHa1. rewrite gempty. + reflexivity. + + rewrite IHa0. rewrite gempty. + reflexivity. + + reflexivity. + - destruct i; simpl; congruence. + Qed. + End NONE_NONE. + + Section IDEM. + Hypothesis f_idem : forall x, f x x = x. + + Fixpoint map2_idem (a b : pmap) := + if pmap_eq a b then a else + match a with + | Empty => map2_Empty b + | (Node a0 af a1) => + match b with + | (Node b0 bf b1) => + node (map2_idem a0 b0) (f af bf) (map2_idem a1 b1) + | Empty => + node (map2_idem a0 Empty) (f af None) (map2_idem a1 Empty) + end + end. + + Lemma gmap2_idem: forall a b i, + get i (map2_idem a b) = f (get i a) (get i b). + Proof. + induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. + { destruct pmap_eq. + - subst b. rewrite gempty. congruence. + - rewrite gempty. + rewrite gmap2_Empty by congruence. + reflexivity. + } + destruct pmap_eq. + { subst b. + congruence. + } + destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. + - destruct i; simpl. + + rewrite IHa1. rewrite gempty. + reflexivity. + + rewrite IHa0. rewrite gempty. + reflexivity. + + reflexivity. + - destruct i; simpl; congruence. + Qed. + End IDEM. +End MAP2. -- cgit From 540fbd2e6d63c1be0dd520499132c134f5b0f8b3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 16 Apr 2020 23:18:26 +0200 Subject: moved to extra --- backend/LICMaux.ml | 25 +-- lib/HashedMap.v | 448 -------------------------------------------------- lib/extra/HashedMap.v | 448 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 457 insertions(+), 464 deletions(-) delete mode 100644 lib/HashedMap.v create mode 100644 lib/extra/HashedMap.v diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 3f7d61b1..96214054 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -1,31 +1,24 @@ open RTL;; open Camlcoq;; open Maps;; -open Integers;; type reg = P.t;; -module IntSet = Set.Make(struct type t=int let compare = (-) end);; - -let loop_headers (f : coq_function) = - PTree.fold (fun (already : IntSet.t) - (coq_pc : node) (instr : instruction) -> - let pc = P.to_int coq_pc in - List.fold_left (fun (already : IntSet.t) (coq_pc' : node) -> - let pc' = P.to_int coq_pc' in - if pc' >= pc - then IntSet.add pc' already - else already) already (successors_instr instr)) - f.fn_code IntSet.empty;; +let loop_headers (f : coq_function) : RTL.node list = + List.map fst (List.filter snd (PTree.elements (Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint)));; let print_loop_headers f = print_endline "Loop headers"; - IntSet.iter - (fun i -> Printf.printf "%d " i) + List.iter + (fun i -> Printf.printf "%d " (P.to_int i)) (loop_headers f); print_newline ();; let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): - (Inject.inj_instr list) PTree.t = + (Inject.inj_instr list) PTree.t = + let _ = print_loop_headers f in + PTree.empty;; +(* let max_reg = P.to_int coq_max_reg in PTree.set coq_max_pc [Inject.INJload(AST.Mint32, (Op.Aindexed (Ptrofs.of_int (Z.of_sint 0))), [P.of_int 1], P.of_int (max_reg+1))] PTree.empty;; + *) diff --git a/lib/HashedMap.v b/lib/HashedMap.v deleted file mode 100644 index df724867..00000000 --- a/lib/HashedMap.v +++ /dev/null @@ -1,448 +0,0 @@ -Require Import ZArith. -Require Import Bool. -Require Import List. -Require Coq.Logic.Eqdep_dec. - -(* begin from Maps *) -Fixpoint prev_append (i j: positive) {struct i} : positive := - match i with - | xH => j - | xI i' => prev_append i' (xI j) - | xO i' => prev_append i' (xO j) - end. - -Definition prev (i: positive) : positive := - prev_append i xH. - -Lemma prev_append_prev i j: - prev (prev_append i j) = prev_append j i. -Proof. - revert j. unfold prev. - induction i as [i IH|i IH|]. 3: reflexivity. - intros j. simpl. rewrite IH. reflexivity. - intros j. simpl. rewrite IH. reflexivity. -Qed. - -Lemma prev_involutive i : - prev (prev i) = i. -Proof (prev_append_prev i xH). - -Lemma prev_append_inj i j j' : - prev_append i j = prev_append i j' -> j = j'. -Proof. - revert j j'. - induction i as [i Hi|i Hi|]; intros j j' H; auto; - specialize (Hi _ _ H); congruence. -Qed. - -(* end from Maps *) - -Lemma orb_idem: forall b, orb b b = b. -Proof. - destruct b; reflexivity. -Qed. - -Lemma andb_idem: forall b, andb b b = b. -Proof. - destruct b; reflexivity. -Qed. - -Lemma andb_negb_false: forall b, andb b (negb b) = false. -Proof. - destruct b; reflexivity. -Qed. - -Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false : pmap. - -Parameter T : Type. -Parameter T_eq_dec : forall (x y : T), {x = y} + {x <> y}. - -Inductive pmap : Type := -| Empty : pmap -| Node : pmap -> option T -> pmap -> pmap. -Definition empty := Empty. - -Definition is_empty x := - match x with - | Empty => true - | Node _ _ _ => false - end. - -Definition is_some (x : option T) := - match x with - | Some _ => true - | None => false - end. - -Fixpoint wf x := - match x with - | Empty => true - | Node b0 f b1 => - (wf b0) && (wf b1) && - ((negb (is_empty b0)) || (is_some f) || (negb (is_empty b1))) - end. - -Definition iswf x := (wf x)=true. - -Lemma empty_wf : iswf empty. -Proof. - reflexivity. -Qed. - -Definition pmap_eq : - forall s s': pmap, { s=s' } + { s <> s' }. -Proof. - generalize T_eq_dec. - induction s; destruct s'; repeat decide equality. -Qed. - -Fixpoint get (i : positive) (s : pmap) {struct i} : option T := - match s with - | Empty => None - | Node b0 f b1 => - match i with - | xH => f - | xO ii => get ii b0 - | xI ii => get ii b1 - end - end. - -Lemma gempty : - forall i : positive, - get i Empty = None. -Proof. - destruct i; simpl; reflexivity. -Qed. - -Hint Resolve gempty : pmap. -Hint Rewrite gempty : pmap. - -Definition node (b0 : pmap) (f : option T) (b1 : pmap) : pmap := - match b0, f, b1 with - | Empty, None, Empty => Empty - | _, _, _ => Node b0 f b1 - end. - -Lemma wf_node : - forall b0 f b1, - iswf b0 -> iswf b1 -> iswf (node b0 f b1). -Proof. - destruct b0; destruct f; destruct b1; simpl. - all: unfold iswf; simpl; intros; trivial. - all: autorewrite with pmap; trivial. - all: rewrite H. - all: rewrite H0. - all: reflexivity. -Qed. - -Hint Resolve wf_node: pmap. - -Lemma gnode : - forall b0 f b1 i, - get i (node b0 f b1) = - get i (Node b0 f b1). -Proof. - destruct b0; simpl; trivial. - destruct f; simpl; trivial. - destruct b1; simpl; trivial. - intro. - rewrite gempty. - destruct i; simpl; trivial. - all: symmetry; apply gempty. -Qed. - -Hint Rewrite gnode : pmap. - -Fixpoint set (i : positive) (j : T) (s : pmap) {struct i} : pmap := - match s with - | Empty => - match i with - | xH => Node Empty (Some j) Empty - | xO ii => Node (set ii j Empty) None Empty - | xI ii => Node Empty None (set ii j Empty) - end - | Node b0 f b1 => - match i with - | xH => Node b0 (Some j) b1 - | xO ii => Node (set ii j b0) f b1 - | xI ii => Node b0 f (set ii j b1) - end - end. - -Lemma set_nonempty: - forall i j s, is_empty (set i j s) = false. -Proof. - induction i; destruct s; simpl; trivial. -Qed. - -Hint Rewrite set_nonempty : pmap. -Hint Resolve set_nonempty : pmap. - -Lemma wf_set: - forall i j s, (iswf s) -> (iswf (set i j s)). -Proof. - induction i; destruct s; simpl; trivial. - all: unfold iswf in *; simpl. - all: autorewrite with pmap; simpl; trivial. - 1,3: auto with pmap. - all: intro Z. - all: repeat rewrite andb_true_iff in Z. - all: intuition. -Qed. - -Hint Resolve wf_set : pset. - -Theorem gss : - forall (i : positive) (j : T) (s : pmap), - get i (set i j s) = Some j. -Proof. - induction i; destruct s; simpl; auto. -Qed. - -Hint Resolve gss : pmap. -Hint Rewrite gss : pmap. - -Theorem gso : - forall (i j : positive) (k : T) (s : pmap), - i <> j -> - get j (set i k s) = get j s. -Proof. - induction i; destruct j; destruct s; simpl; intro; auto with pmap. - 5, 6: congruence. - all: rewrite IHi by congruence. - all: trivial. - all: apply gempty. -Qed. - -Hint Resolve gso : pmap. - -Fixpoint remove (i : positive) (s : pmap) { struct i } : pmap := - match i with - | xH => - match s with - | Empty => Empty - | Node b0 f b1 => node b0 None b1 - end - | xO ii => - match s with - | Empty => Empty - | Node b0 f b1 => node (remove ii b0) f b1 - end - | xI ii => - match s with - | Empty => Empty - | Node b0 f b1 => node b0 f (remove ii b1) - end - end. - -Lemma wf_remove : - forall i s, (iswf s) -> (iswf (remove i s)). -Proof. - induction i; destruct s; simpl; trivial. - all: unfold iswf in *; simpl. - all: intro Z. - all: repeat rewrite andb_true_iff in Z. - all: apply wf_node. - all: intuition. - all: apply IHi. - all: assumption. -Qed. - -Fixpoint remove_noncanon (i : positive) (s : pmap) { struct i } : pmap := - match i with - | xH => - match s with - | Empty => Empty - | Node b0 f b1 => Node b0 None b1 - end - | xO ii => - match s with - | Empty => Empty - | Node b0 f b1 => Node (remove_noncanon ii b0) f b1 - end - | xI ii => - match s with - | Empty => Empty - | Node b0 f b1 => Node b0 f (remove_noncanon ii b1) - end - end. - -Lemma remove_noncanon_same: - forall i j s, (get j (remove i s)) = (get j (remove_noncanon i s)). -Proof. - induction i; destruct s; simpl; trivial. - all: rewrite gnode. - 3: reflexivity. - all: destruct j; simpl; trivial. -Qed. - -Lemma remove_empty : - forall i, remove i Empty = Empty. -Proof. - induction i; simpl; trivial. -Qed. - -Hint Rewrite remove_empty : pmap. -Hint Resolve remove_empty : pmap. - -Lemma gremove_noncanon_s : - forall i : positive, - forall s : pmap, - get i (remove_noncanon i s) = None. -Proof. - induction i; destruct s; simpl; trivial. -Qed. - -Theorem grs : - forall i : positive, - forall s : pmap, - get i (remove i s) = None. -Proof. - intros. - rewrite remove_noncanon_same. - apply gremove_noncanon_s. -Qed. - -Hint Resolve grs : pmap. -Hint Rewrite grs : pmap. - -Lemma gremove_noncanon_o : - forall i j : positive, - forall s : pmap, - i<>j -> - get j (remove_noncanon i s) = get j s. -Proof. - induction i; destruct j; destruct s; simpl; intro; trivial. - 1, 2: rewrite IHi by congruence. - 1, 2: reflexivity. - congruence. -Qed. - -Theorem gro : - forall (i j : positive) (s : pmap), - i<>j -> - get j (remove i s) = get j s. -Proof. - intros. - rewrite remove_noncanon_same. - apply gremove_noncanon_o. - assumption. -Qed. - -Hint Resolve gro : pmap. - -Section MAP2. - - Variable f : option T -> option T -> option T. - - Section NONE_NONE. - Hypothesis f_none_none : f None None = None. - - Fixpoint map2_Empty (b : pmap) := - match b with - | Empty => Empty - | Node b0 bf b1 => - node (map2_Empty b0) (f None bf) (map2_Empty b1) - end. - - Lemma gmap2_Empty: forall i b, - get i (map2_Empty b) = f None (get i b). - Proof. - induction i; destruct b as [ | b0 bf b1]; intros; simpl in *. - all: try congruence. - - replace - (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with - | Empty => None - | Node _ _ c1 => get i c1 - end) - with (get (xI i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). - + rewrite gnode. - simpl. apply IHi. - + destruct node; auto with pmap. - - replace - (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with - | Empty => None - | Node c0 _ _ => get i c0 - end) - with (get (xO i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). - + rewrite gnode. - simpl. apply IHi. - + destruct node; auto with pmap. - - change (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with - | Empty => None - | Node _ cf _ => cf - end) with (get xH (node (map2_Empty b0) (f None bf) (map2_Empty b1))). - rewrite gnode. reflexivity. - Qed. - - Fixpoint map2 (a b : pmap) := - match a with - | Empty => map2_Empty b - | (Node a0 af a1) => - match b with - | (Node b0 bf b1) => - node (map2 a0 b0) (f af bf) (map2 a1 b1) - | Empty => - node (map2 a0 Empty) (f af None) (map2 a1 Empty) - end - end. - - Lemma gmap2: forall a b i, - get i (map2 a b) = f (get i a) (get i b). - Proof. - induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. - { rewrite gmap2_Empty. - rewrite gempty. - reflexivity. } - destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. - - destruct i; simpl. - + rewrite IHa1. rewrite gempty. - reflexivity. - + rewrite IHa0. rewrite gempty. - reflexivity. - + reflexivity. - - destruct i; simpl; congruence. - Qed. - End NONE_NONE. - - Section IDEM. - Hypothesis f_idem : forall x, f x x = x. - - Fixpoint map2_idem (a b : pmap) := - if pmap_eq a b then a else - match a with - | Empty => map2_Empty b - | (Node a0 af a1) => - match b with - | (Node b0 bf b1) => - node (map2_idem a0 b0) (f af bf) (map2_idem a1 b1) - | Empty => - node (map2_idem a0 Empty) (f af None) (map2_idem a1 Empty) - end - end. - - Lemma gmap2_idem: forall a b i, - get i (map2_idem a b) = f (get i a) (get i b). - Proof. - induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. - { destruct pmap_eq. - - subst b. rewrite gempty. congruence. - - rewrite gempty. - rewrite gmap2_Empty by congruence. - reflexivity. - } - destruct pmap_eq. - { subst b. - congruence. - } - destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. - - destruct i; simpl. - + rewrite IHa1. rewrite gempty. - reflexivity. - + rewrite IHa0. rewrite gempty. - reflexivity. - + reflexivity. - - destruct i; simpl; congruence. - Qed. - End IDEM. -End MAP2. diff --git a/lib/extra/HashedMap.v b/lib/extra/HashedMap.v new file mode 100644 index 00000000..df724867 --- /dev/null +++ b/lib/extra/HashedMap.v @@ -0,0 +1,448 @@ +Require Import ZArith. +Require Import Bool. +Require Import List. +Require Coq.Logic.Eqdep_dec. + +(* begin from Maps *) +Fixpoint prev_append (i j: positive) {struct i} : positive := + match i with + | xH => j + | xI i' => prev_append i' (xI j) + | xO i' => prev_append i' (xO j) + end. + +Definition prev (i: positive) : positive := + prev_append i xH. + +Lemma prev_append_prev i j: + prev (prev_append i j) = prev_append j i. +Proof. + revert j. unfold prev. + induction i as [i IH|i IH|]. 3: reflexivity. + intros j. simpl. rewrite IH. reflexivity. + intros j. simpl. rewrite IH. reflexivity. +Qed. + +Lemma prev_involutive i : + prev (prev i) = i. +Proof (prev_append_prev i xH). + +Lemma prev_append_inj i j j' : + prev_append i j = prev_append i j' -> j = j'. +Proof. + revert j j'. + induction i as [i Hi|i Hi|]; intros j j' H; auto; + specialize (Hi _ _ H); congruence. +Qed. + +(* end from Maps *) + +Lemma orb_idem: forall b, orb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_idem: forall b, andb b b = b. +Proof. + destruct b; reflexivity. +Qed. + +Lemma andb_negb_false: forall b, andb b (negb b) = false. +Proof. + destruct b; reflexivity. +Qed. + +Hint Rewrite orb_false_r andb_false_r andb_true_r orb_true_r orb_idem andb_idem andb_negb_false : pmap. + +Parameter T : Type. +Parameter T_eq_dec : forall (x y : T), {x = y} + {x <> y}. + +Inductive pmap : Type := +| Empty : pmap +| Node : pmap -> option T -> pmap -> pmap. +Definition empty := Empty. + +Definition is_empty x := + match x with + | Empty => true + | Node _ _ _ => false + end. + +Definition is_some (x : option T) := + match x with + | Some _ => true + | None => false + end. + +Fixpoint wf x := + match x with + | Empty => true + | Node b0 f b1 => + (wf b0) && (wf b1) && + ((negb (is_empty b0)) || (is_some f) || (negb (is_empty b1))) + end. + +Definition iswf x := (wf x)=true. + +Lemma empty_wf : iswf empty. +Proof. + reflexivity. +Qed. + +Definition pmap_eq : + forall s s': pmap, { s=s' } + { s <> s' }. +Proof. + generalize T_eq_dec. + induction s; destruct s'; repeat decide equality. +Qed. + +Fixpoint get (i : positive) (s : pmap) {struct i} : option T := + match s with + | Empty => None + | Node b0 f b1 => + match i with + | xH => f + | xO ii => get ii b0 + | xI ii => get ii b1 + end + end. + +Lemma gempty : + forall i : positive, + get i Empty = None. +Proof. + destruct i; simpl; reflexivity. +Qed. + +Hint Resolve gempty : pmap. +Hint Rewrite gempty : pmap. + +Definition node (b0 : pmap) (f : option T) (b1 : pmap) : pmap := + match b0, f, b1 with + | Empty, None, Empty => Empty + | _, _, _ => Node b0 f b1 + end. + +Lemma wf_node : + forall b0 f b1, + iswf b0 -> iswf b1 -> iswf (node b0 f b1). +Proof. + destruct b0; destruct f; destruct b1; simpl. + all: unfold iswf; simpl; intros; trivial. + all: autorewrite with pmap; trivial. + all: rewrite H. + all: rewrite H0. + all: reflexivity. +Qed. + +Hint Resolve wf_node: pmap. + +Lemma gnode : + forall b0 f b1 i, + get i (node b0 f b1) = + get i (Node b0 f b1). +Proof. + destruct b0; simpl; trivial. + destruct f; simpl; trivial. + destruct b1; simpl; trivial. + intro. + rewrite gempty. + destruct i; simpl; trivial. + all: symmetry; apply gempty. +Qed. + +Hint Rewrite gnode : pmap. + +Fixpoint set (i : positive) (j : T) (s : pmap) {struct i} : pmap := + match s with + | Empty => + match i with + | xH => Node Empty (Some j) Empty + | xO ii => Node (set ii j Empty) None Empty + | xI ii => Node Empty None (set ii j Empty) + end + | Node b0 f b1 => + match i with + | xH => Node b0 (Some j) b1 + | xO ii => Node (set ii j b0) f b1 + | xI ii => Node b0 f (set ii j b1) + end + end. + +Lemma set_nonempty: + forall i j s, is_empty (set i j s) = false. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Hint Rewrite set_nonempty : pmap. +Hint Resolve set_nonempty : pmap. + +Lemma wf_set: + forall i j s, (iswf s) -> (iswf (set i j s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: autorewrite with pmap; simpl; trivial. + 1,3: auto with pmap. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: intuition. +Qed. + +Hint Resolve wf_set : pset. + +Theorem gss : + forall (i : positive) (j : T) (s : pmap), + get i (set i j s) = Some j. +Proof. + induction i; destruct s; simpl; auto. +Qed. + +Hint Resolve gss : pmap. +Hint Rewrite gss : pmap. + +Theorem gso : + forall (i j : positive) (k : T) (s : pmap), + i <> j -> + get j (set i k s) = get j s. +Proof. + induction i; destruct j; destruct s; simpl; intro; auto with pmap. + 5, 6: congruence. + all: rewrite IHi by congruence. + all: trivial. + all: apply gempty. +Qed. + +Hint Resolve gso : pmap. + +Fixpoint remove (i : positive) (s : pmap) { struct i } : pmap := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 None b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => node (remove ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => node b0 f (remove ii b1) + end + end. + +Lemma wf_remove : + forall i s, (iswf s) -> (iswf (remove i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: unfold iswf in *; simpl. + all: intro Z. + all: repeat rewrite andb_true_iff in Z. + all: apply wf_node. + all: intuition. + all: apply IHi. + all: assumption. +Qed. + +Fixpoint remove_noncanon (i : positive) (s : pmap) { struct i } : pmap := + match i with + | xH => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 None b1 + end + | xO ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node (remove_noncanon ii b0) f b1 + end + | xI ii => + match s with + | Empty => Empty + | Node b0 f b1 => Node b0 f (remove_noncanon ii b1) + end + end. + +Lemma remove_noncanon_same: + forall i j s, (get j (remove i s)) = (get j (remove_noncanon i s)). +Proof. + induction i; destruct s; simpl; trivial. + all: rewrite gnode. + 3: reflexivity. + all: destruct j; simpl; trivial. +Qed. + +Lemma remove_empty : + forall i, remove i Empty = Empty. +Proof. + induction i; simpl; trivial. +Qed. + +Hint Rewrite remove_empty : pmap. +Hint Resolve remove_empty : pmap. + +Lemma gremove_noncanon_s : + forall i : positive, + forall s : pmap, + get i (remove_noncanon i s) = None. +Proof. + induction i; destruct s; simpl; trivial. +Qed. + +Theorem grs : + forall i : positive, + forall s : pmap, + get i (remove i s) = None. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_s. +Qed. + +Hint Resolve grs : pmap. +Hint Rewrite grs : pmap. + +Lemma gremove_noncanon_o : + forall i j : positive, + forall s : pmap, + i<>j -> + get j (remove_noncanon i s) = get j s. +Proof. + induction i; destruct j; destruct s; simpl; intro; trivial. + 1, 2: rewrite IHi by congruence. + 1, 2: reflexivity. + congruence. +Qed. + +Theorem gro : + forall (i j : positive) (s : pmap), + i<>j -> + get j (remove i s) = get j s. +Proof. + intros. + rewrite remove_noncanon_same. + apply gremove_noncanon_o. + assumption. +Qed. + +Hint Resolve gro : pmap. + +Section MAP2. + + Variable f : option T -> option T -> option T. + + Section NONE_NONE. + Hypothesis f_none_none : f None None = None. + + Fixpoint map2_Empty (b : pmap) := + match b with + | Empty => Empty + | Node b0 bf b1 => + node (map2_Empty b0) (f None bf) (map2_Empty b1) + end. + + Lemma gmap2_Empty: forall i b, + get i (map2_Empty b) = f None (get i b). + Proof. + induction i; destruct b as [ | b0 bf b1]; intros; simpl in *. + all: try congruence. + - replace + (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node _ _ c1 => get i c1 + end) + with (get (xI i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - replace + (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node c0 _ _ => get i c0 + end) + with (get (xO i) (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + + rewrite gnode. + simpl. apply IHi. + + destruct node; auto with pmap. + - change (match node (map2_Empty b0) (f None bf) (map2_Empty b1) with + | Empty => None + | Node _ cf _ => cf + end) with (get xH (node (map2_Empty b0) (f None bf) (map2_Empty b1))). + rewrite gnode. reflexivity. + Qed. + + Fixpoint map2 (a b : pmap) := + match a with + | Empty => map2_Empty b + | (Node a0 af a1) => + match b with + | (Node b0 bf b1) => + node (map2 a0 b0) (f af bf) (map2 a1 b1) + | Empty => + node (map2 a0 Empty) (f af None) (map2 a1 Empty) + end + end. + + Lemma gmap2: forall a b i, + get i (map2 a b) = f (get i a) (get i b). + Proof. + induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. + { rewrite gmap2_Empty. + rewrite gempty. + reflexivity. } + destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. + - destruct i; simpl. + + rewrite IHa1. rewrite gempty. + reflexivity. + + rewrite IHa0. rewrite gempty. + reflexivity. + + reflexivity. + - destruct i; simpl; congruence. + Qed. + End NONE_NONE. + + Section IDEM. + Hypothesis f_idem : forall x, f x x = x. + + Fixpoint map2_idem (a b : pmap) := + if pmap_eq a b then a else + match a with + | Empty => map2_Empty b + | (Node a0 af a1) => + match b with + | (Node b0 bf b1) => + node (map2_idem a0 b0) (f af bf) (map2_idem a1 b1) + | Empty => + node (map2_idem a0 Empty) (f af None) (map2_idem a1 Empty) + end + end. + + Lemma gmap2_idem: forall a b i, + get i (map2_idem a b) = f (get i a) (get i b). + Proof. + induction a as [ | a0 IHa0 af a1 IHa1]; intros; simpl. + { destruct pmap_eq. + - subst b. rewrite gempty. congruence. + - rewrite gempty. + rewrite gmap2_Empty by congruence. + reflexivity. + } + destruct pmap_eq. + { subst b. + congruence. + } + destruct b as [ | b0 bf b1 ]; simpl; rewrite gnode. + - destruct i; simpl. + + rewrite IHa1. rewrite gempty. + reflexivity. + + rewrite IHa0. rewrite gempty. + reflexivity. + + reflexivity. + - destruct i; simpl; congruence. + Qed. + End IDEM. +End MAP2. -- cgit From 967dbc3b939784ef3246bb5e931a62da26cf51a9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 17 Apr 2020 12:27:48 +0200 Subject: find inner loops --- backend/LICMaux.ml | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 96214054..82cd74a2 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -1,9 +1,65 @@ open RTL;; open Camlcoq;; open Maps;; +open Kildall;; type reg = P.t;; +module Dominator = + struct + type t = Unreachable | Dominated of int | Multiple + let bot = Unreachable and top = Multiple + let beq a b = + match a, b with + | Unreachable, Unreachable + | Multiple, Multiple -> true + | (Dominated x), (Dominated y) -> x = y + | _ -> false + let lub a b = + match a, b with + | Multiple, _ + | _, Multiple -> Multiple + | Unreachable, x + | x, Unreachable -> x + | (Dominated x), (Dominated y) when x=y -> a + | (Dominated _), (Dominated _) -> Multiple + + let pp oc = function + | Unreachable -> output_string oc "unreachable" + | Multiple -> output_string oc "multiple" + | Dominated x -> Printf.fprintf oc "%d" x;; + end + +module Dominator_Solver = Dataflow_Solver(Dominator)(NodeSetForward) + +let apply_dominator (is_marked : node -> bool) (pc : node) + (before : Dominator.t) : Dominator.t = + match before with + | Dominator.Unreachable -> before + | _ -> + if is_marked pc + then Dominator.Dominated (P.to_int pc) + else before;; + +let dominated_parts (f : coq_function) : Dominator.t PMap.t option = + let headers = Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint in + Dominator_Solver.fixpoint f.fn_code RTL.successors_instr + (apply_dominator (fun pc -> match PTree.get pc headers with + | Some x -> x + | None -> false)) f.fn_entrypoint + Dominator.top;; + +let print_dominated_parts oc f = + match dominated_parts f with + | None -> output_string oc "error\n" + | Some parts -> + List.iter + (fun (pc, instr) -> + Printf.fprintf oc "%d : %a\n" (P.to_int pc) Dominator.pp + (PMap.get pc parts) + ) + (PTree.elements f.fn_code);; + let loop_headers (f : coq_function) : RTL.node list = List.map fst (List.filter snd (PTree.elements (Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint)));; @@ -16,7 +72,7 @@ let print_loop_headers f = let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): (Inject.inj_instr list) PTree.t = - let _ = print_loop_headers f in + let _ = print_dominated_parts stdout f in PTree.empty;; (* let max_reg = P.to_int coq_max_reg in -- cgit From 871643ce4897ba645d922812a3fb546bdb2f48a4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 11:29:18 +0200 Subject: headers vs dominators --- backend/LICMaux.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 82cd74a2..e236b173 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -41,16 +41,18 @@ let apply_dominator (is_marked : node -> bool) (pc : node) then Dominator.Dominated (P.to_int pc) else before;; -let dominated_parts (f : coq_function) : Dominator.t PMap.t option = +let dominated_parts (f : coq_function) : + (bool PTree.t) * (Dominator.t PMap.t option) = let headers = Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint in - Dominator_Solver.fixpoint f.fn_code RTL.successors_instr + let dominated = Dominator_Solver.fixpoint f.fn_code RTL.successors_instr (apply_dominator (fun pc -> match PTree.get pc headers with | Some x -> x | None -> false)) f.fn_entrypoint - Dominator.top;; + Dominator.top in + (headers, dominated);; let print_dominated_parts oc f = - match dominated_parts f with + match snd (dominated_parts f) with | None -> output_string oc "error\n" | Some parts -> List.iter -- cgit From 669612fc3165cd9898decb7ae5c70f9fb4ef327b Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 17:12:42 +0200 Subject: dominated parts --- backend/LICMaux.ml | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index e236b173..52e5077f 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -2,6 +2,7 @@ open RTL;; open Camlcoq;; open Maps;; open Kildall;; +open HashedSet;; type reg = P.t;; @@ -41,7 +42,7 @@ let apply_dominator (is_marked : node -> bool) (pc : node) then Dominator.Dominated (P.to_int pc) else before;; -let dominated_parts (f : coq_function) : +let dominated_parts1 (f : coq_function) : (bool PTree.t) * (Dominator.t PMap.t option) = let headers = Duplicateaux.get_loop_headers f.fn_code f.fn_entrypoint in let dominated = Dominator_Solver.fixpoint f.fn_code RTL.successors_instr @@ -51,8 +52,20 @@ let dominated_parts (f : coq_function) : Dominator.top in (headers, dominated);; +(* unfinished *) +let dominated_parts (f : coq_function) : + PSet.t PTree.t = + let (headers, dominated) = dominated_parts1 f in + match dominated with + | None -> failwith "dominated_parts" + | Some dominated -> + PTree.fold (fun before pc flag -> + if flag + then PTree.set pc PSet.empty before + else before) headers PTree.empty;; + let print_dominated_parts oc f = - match snd (dominated_parts f) with + match snd (dominated_parts1 f) with | None -> output_string oc "error\n" | Some parts -> List.iter -- cgit From a352cc3f9b9355e8b823750b9c4e5e1d37606dc4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 19:01:48 +0200 Subject: dominated sets --- backend/LICMaux.ml | 34 ++++++++++++++++++++++++++++++---- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 52e5077f..66c1530e 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -57,14 +57,40 @@ let dominated_parts (f : coq_function) : PSet.t PTree.t = let (headers, dominated) = dominated_parts1 f in match dominated with - | None -> failwith "dominated_parts" + | None -> failwith "dominated_parts 1" | Some dominated -> - PTree.fold (fun before pc flag -> + let singletons = + PTree.fold (fun before pc flag -> if flag - then PTree.set pc PSet.empty before - else before) headers PTree.empty;; + then PTree.set pc (PSet.add pc PSet.empty) before + else before) headers PTree.empty in + PTree.fold (fun before pc ii -> + match PMap.get pc dominated with + | Dominator.Dominated x -> + let px = P.of_int x in + (match PTree.get px before with + | None -> failwith "dominated_parts 2" + | Some old -> + PTree.set px (PSet.add pc old) before) + | _ -> before) f.fn_code singletons;; + +let pp_pset oc s = + output_string oc "{ "; + let first = ref true in + List.iter (fun x -> + (if !first + then first := false + else output_string oc ", "); + Printf.printf "%d" x) + (List.sort (fun x y -> y - x) (List.map P.to_int (PSet.elements s))); + output_string oc " }";; let print_dominated_parts oc f = + List.iter (fun (header, nodes) -> + Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) + (PTree.elements (dominated_parts f));; + +let print_dominated_parts1 oc f = match snd (dominated_parts1 f) with | None -> output_string oc "error\n" | Some parts -> -- cgit From 9c68c213d09347316f3bd150dc4c34798c317db1 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 21:47:46 +0200 Subject: backward iterator --- backend/LICMaux.ml | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 66c1530e..269d9353 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -53,8 +53,7 @@ let dominated_parts1 (f : coq_function) : (headers, dominated);; (* unfinished *) -let dominated_parts (f : coq_function) : - PSet.t PTree.t = +let dominated_parts (f : coq_function) : PSet.t PTree.t = let (headers, dominated) = dominated_parts1 f in match dominated with | None -> failwith "dominated_parts 1" @@ -74,6 +73,36 @@ let dominated_parts (f : coq_function) : PTree.set px (PSet.add pc old) before) | _ -> before) f.fn_code singletons;; +let graph_traversal (initial_node : P.t) + (successor_iterator : P.t -> (P.t -> unit) -> unit) : PSet.t = + let seen = ref PSet.empty + and stack = Stack.create () in + Stack.push initial_node stack; + while not (Stack.is_empty stack) + do + let vertex = Stack.pop stack in + if not (PSet.contains !seen vertex) + then + begin + seen := PSet.add vertex !seen; + successor_iterator vertex (fun x -> Stack.push x stack) + end + done; + !seen;; + +let filter_dominated_part (predecessors : P.t list PTree.t) + (header : P.t) (dominated_part : PSet.t) = + graph_traversal header + (fun (vertex : P.t) (f : P.t -> unit) -> + match PTree.get vertex predecessors with + | None -> () + | Some l -> + List.iter + (fun x -> + if PSet.contains dominated_part x + then f x) l + );; + let pp_pset oc s = output_string oc "{ "; let first = ref true in -- cgit From 2efb64e96105c90f68f22a0a0bc386d1ac039354 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 22:00:49 +0200 Subject: compute inner loops --- backend/LICMaux.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 269d9353..ecc11a00 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -52,7 +52,6 @@ let dominated_parts1 (f : coq_function) : Dominator.top in (headers, dominated);; -(* unfinished *) let dominated_parts (f : coq_function) : PSet.t PTree.t = let (headers, dominated) = dominated_parts1 f in match dominated with @@ -103,6 +102,11 @@ let filter_dominated_part (predecessors : P.t list PTree.t) then f x) l );; +let inner_loops (f : coq_function) : PSet.t PTree.t = + let parts = dominated_parts f + and predecessors = Kildall.make_predecessors f.fn_code RTL.successors_instr in + PTree.map (filter_dominated_part predecessors) parts;; + let pp_pset oc s = output_string oc "{ "; let first = ref true in @@ -119,6 +123,11 @@ let print_dominated_parts oc f = Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) (PTree.elements (dominated_parts f));; +let print_inner_loops oc f = + List.iter (fun (header, nodes) -> + Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) + (PTree.elements (inner_loops f));; + let print_dominated_parts1 oc f = match snd (dominated_parts1 f) with | None -> output_string oc "error\n" @@ -142,7 +151,7 @@ let print_loop_headers f = let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): (Inject.inj_instr list) PTree.t = - let _ = print_dominated_parts stdout f in + let _ = print_inner_loops stdout f in PTree.empty;; (* let max_reg = P.to_int coq_max_reg in -- cgit From 300e51261c090e6a66bd0e0004bb530b64caf6e9 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sat, 18 Apr 2020 22:37:01 +0200 Subject: pp_list --- backend/LICMaux.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index ecc11a00..39e336eb 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -107,17 +107,20 @@ let inner_loops (f : coq_function) : PSet.t PTree.t = and predecessors = Kildall.make_predecessors f.fn_code RTL.successors_instr in PTree.map (filter_dominated_part predecessors) parts;; -let pp_pset oc s = +let pp_list pp_item oc l = output_string oc "{ "; let first = ref true in List.iter (fun x -> (if !first then first := false else output_string oc ", "); - Printf.printf "%d" x) - (List.sort (fun x y -> y - x) (List.map P.to_int (PSet.elements s))); + pp_item oc x) l; output_string oc " }";; +let pp_pset oc s = + pp_list (fun oc -> Printf.fprintf oc "%d") oc + (List.sort (fun x y -> y - x) (List.map P.to_int (PSet.elements s)));; + let print_dominated_parts oc f = List.iter (fun (header, nodes) -> Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) -- cgit From 9c97918742e00798bad8c7862de92831bb62a69e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 17:26:05 +0200 Subject: try building injection lists --- backend/LICMaux.ml | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 39e336eb..5028869f 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -3,6 +3,7 @@ open Camlcoq;; open Maps;; open Kildall;; open HashedSet;; +open Inject;; type reg = P.t;; @@ -107,6 +108,57 @@ let inner_loops (f : coq_function) : PSet.t PTree.t = and predecessors = Kildall.make_predecessors f.fn_code RTL.successors_instr in PTree.map (filter_dominated_part predecessors) parts;; +let map_reg mapper r = + match PTree.get r mapper with + | None -> r + | Some x -> x;; + +let rewrite_loop_body (last_alloc : reg ref) + (insns : RTL.code) (header : P.t) (loop_body : PSet.t) = + let seen = ref PSet.empty + and stack = Stack.create () + and rewritten = ref [] in + let add_inj ii = rewritten := ii::!rewritten in + Stack.push (header, PTree.empty) stack; + while not (Stack.is_empty stack) + do + let (pc, mapper) = Stack.pop stack in + if not (PSet.contains !seen pc) + then + begin + seen := PSet.add pc !seen; + match PTree.get pc insns with + | None -> () + | Some ii -> + let mapper' = + match ii with + | Iop(op, args, res, pc') -> + let new_res = P.succ !last_alloc in + last_alloc := new_res; + add_inj (INJop(op, + (List.map (map_reg mapper) args), + new_res)); + PTree.set res new_res mapper + | Iload(trap, chunk, addr, args, res, pc') -> + let new_res = P.succ !last_alloc in + last_alloc := new_res; + add_inj (INJload(chunk, addr, + (List.map (map_reg mapper) args), + new_res)); + PTree.set res new_res mapper + | _ -> mapper in + List.iter (fun x -> Stack.push (x, mapper') stack) + (successors_instr ii) + end + done; + List.rev !rewritten;; + +(* +| INJnop +| INJop of operation * reg list * reg +| INJload of memory_chunk * addressing * reg list * reg + *) + let pp_list pp_item oc l = output_string oc "{ "; let first = ref true in -- cgit From 1e361a51e7efa560f378db2c0c9993261cabe008 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 17:50:49 +0200 Subject: synthesize injection lists --- backend/LICMaux.ml | 38 ++++++++++++++++++++++++++++++-------- 1 file changed, 30 insertions(+), 8 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 5028869f..531f1f9e 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -147,18 +147,40 @@ let rewrite_loop_body (last_alloc : reg ref) new_res)); PTree.set res new_res mapper | _ -> mapper in - List.iter (fun x -> Stack.push (x, mapper') stack) + List.iter (fun x -> + if PSet.contains loop_body x + then Stack.push (x, mapper') stack) (successors_instr ii) end done; List.rev !rewritten;; -(* -| INJnop -| INJop of operation * reg list * reg -| INJload of memory_chunk * addressing * reg list * reg - *) - +let pp_inj_instr (oc : out_channel) (ii : inj_instr) = + match ii with + | INJnop -> output_string oc "nop" + | INJop(op, args, res) -> + Printf.fprintf oc "%a = %a" + PrintRTL.reg res (PrintOp.print_operation PrintRTL.reg) (op, args) + | INJload(chunk, addr, args, dst) -> + Printf.fprintf oc "%a = %s[%a]" + PrintRTL.reg dst (PrintAST.name_of_chunk chunk) + (PrintOp.print_addressing PrintRTL.reg) (addr, args);; + +let pp_inj_list (oc : out_channel) (l : inj_instr list) = + List.iter (Printf.fprintf oc "%a; " pp_inj_instr) l;; + +let pp_injections (oc : out_channel) (injections : inj_instr list PTree.t) = + List.iter + (fun (pc, injl) -> + Printf.fprintf oc "%d : %a\n" (P.to_int pc) pp_inj_list injl) + (PTree.elements injections);; + +let compute_injections (f : coq_function) = + let loop_bodies = inner_loops f + and last_alloc = ref (max_reg_function f) in + PTree.map + (rewrite_loop_body last_alloc f.fn_code) loop_bodies;; + let pp_list pp_item oc l = output_string oc "{ "; let first = ref true in @@ -206,7 +228,7 @@ let print_loop_headers f = let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): (Inject.inj_instr list) PTree.t = - let _ = print_inner_loops stdout f in + let _ = pp_injections stdout (compute_injections f) in PTree.empty;; (* let max_reg = P.to_int coq_max_reg in -- cgit From 9010b8750aecd3a1ab45944b7dd4af3f33768f71 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 18:49:34 +0200 Subject: compute injections --- backend/LICMaux.ml | 39 ++++++++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 531f1f9e..314a5cf4 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -53,7 +53,7 @@ let dominated_parts1 (f : coq_function) : Dominator.top in (headers, dominated);; -let dominated_parts (f : coq_function) : PSet.t PTree.t = +let dominated_parts (f : coq_function) : Dominator.t PMap.t * PSet.t PTree.t = let (headers, dominated) = dominated_parts1 f in match dominated with | None -> failwith "dominated_parts 1" @@ -63,6 +63,7 @@ let dominated_parts (f : coq_function) : PSet.t PTree.t = if flag then PTree.set pc (PSet.add pc PSet.empty) before else before) headers PTree.empty in + (dominated, PTree.fold (fun before pc ii -> match PMap.get pc dominated with | Dominator.Dominated x -> @@ -71,7 +72,7 @@ let dominated_parts (f : coq_function) : PSet.t PTree.t = | None -> failwith "dominated_parts 2" | Some old -> PTree.set px (PSet.add pc old) before) - | _ -> before) f.fn_code singletons;; + | _ -> before) f.fn_code singletons);; let graph_traversal (initial_node : P.t) (successor_iterator : P.t -> (P.t -> unit) -> unit) : PSet.t = @@ -103,10 +104,10 @@ let filter_dominated_part (predecessors : P.t list PTree.t) then f x) l );; -let inner_loops (f : coq_function) : PSet.t PTree.t = - let parts = dominated_parts f +let inner_loops (f : coq_function) = + let (dominated, parts) = dominated_parts f and predecessors = Kildall.make_predecessors f.fn_code RTL.successors_instr in - PTree.map (filter_dominated_part predecessors) parts;; + (dominated, predecessors, PTree.map (filter_dominated_part predecessors) parts);; let map_reg mapper r = match PTree.get r mapper with @@ -175,11 +176,27 @@ let pp_injections (oc : out_channel) (injections : inj_instr list PTree.t) = Printf.fprintf oc "%d : %a\n" (P.to_int pc) pp_inj_list injl) (PTree.elements injections);; -let compute_injections (f : coq_function) = - let loop_bodies = inner_loops f +let compute_injections1 (f : coq_function) = + let (dominated, predecessors, loop_bodies) = inner_loops f and last_alloc = ref (max_reg_function f) in - PTree.map - (rewrite_loop_body last_alloc f.fn_code) loop_bodies;; + (dominated, predecessors, + PTree.map (fun header body -> + (body, rewrite_loop_body last_alloc f.fn_code header body)) loop_bodies);; + +let compute_injections (f : coq_function) : inj_instr list PTree.t = + let (dominated, predecessors, injections) = compute_injections1 f in + let output_map = ref PTree.empty in + List.iter + (fun (header, (body, inj)) -> + match PTree.get header predecessors with + | None -> failwith "compute_injections" + | Some l -> + List.iter (fun predecessor -> + if (PMap.get predecessor dominated)<>Dominator.Unreachable && + not (PSet.contains body predecessor) + then output_map := PTree.set predecessor inj !output_map) l) + (PTree.elements injections); + !output_map;; let pp_list pp_item oc l = output_string oc "{ "; @@ -198,12 +215,12 @@ let pp_pset oc s = let print_dominated_parts oc f = List.iter (fun (header, nodes) -> Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) - (PTree.elements (dominated_parts f));; + (PTree.elements (snd (dominated_parts f)));; let print_inner_loops oc f = List.iter (fun (header, nodes) -> Printf.fprintf oc "%d : %a\n" (P.to_int header) pp_pset nodes) - (PTree.elements (inner_loops f));; + (PTree.elements (let (_,_,l) = (inner_loops f) in l));; let print_dominated_parts1 oc f = match snd (dominated_parts1 f) with -- cgit From d0163625ad55f8b01a3c002dd52be83b8a26e35e Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 19:50:14 +0200 Subject: test whether the instructions are allowed --- aarch64/Archi.v | 2 ++ arm/Archi.v | 2 ++ backend/LICMaux.ml | 14 ++++++-------- mppa_k1c/Archi.v | 6 ++++-- powerpc/Archi.v | 2 ++ riscV/Archi.v | 2 ++ test/monniaux/cse2/noloopinvariant.c | 6 ++++++ x86_32/Archi.v | 2 ++ x86_64/Archi.v | 2 ++ 9 files changed, 28 insertions(+), 10 deletions(-) create mode 100644 test/monniaux/cse2/noloopinvariant.c diff --git a/aarch64/Archi.v b/aarch64/Archi.v index aef4ab77..7d7b6887 100644 --- a/aarch64/Archi.v +++ b/aarch64/Archi.v @@ -86,3 +86,5 @@ Global Opaque ptr64 big_endian splitlong (** Whether to generate position-independent code or not *) Parameter pic_code: unit -> bool. + +Definition has_notrap_loads := false. diff --git a/arm/Archi.v b/arm/Archi.v index 16d6c71d..738341cc 100644 --- a/arm/Archi.v +++ b/arm/Archi.v @@ -97,3 +97,5 @@ Parameter abi: abi_kind. (** Whether instructions added with Thumb2 are supported. True for ARMv6T2 and above. *) Parameter thumb2_support: bool. + +Definition has_notrap_loads := false. diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 314a5cf4..0368b94f 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -133,14 +133,15 @@ let rewrite_loop_body (last_alloc : reg ref) | Some ii -> let mapper' = match ii with - | Iop(op, args, res, pc') -> + | Iop(op, args, res, pc') when not (Op.is_trapping_op op) -> let new_res = P.succ !last_alloc in last_alloc := new_res; add_inj (INJop(op, (List.map (map_reg mapper) args), new_res)); PTree.set res new_res mapper - | Iload(trap, chunk, addr, args, res, pc') -> + | Iload(trap, chunk, addr, args, res, pc') + when Archi.has_notrap_loads -> let new_res = P.succ !last_alloc in last_alloc := new_res; add_inj (INJload(chunk, addr, @@ -245,9 +246,6 @@ let print_loop_headers f = let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): (Inject.inj_instr list) PTree.t = - let _ = pp_injections stdout (compute_injections f) in - PTree.empty;; -(* - let max_reg = P.to_int coq_max_reg in - PTree.set coq_max_pc [Inject.INJload(AST.Mint32, (Op.Aindexed (Ptrofs.of_int (Z.of_sint 0))), [P.of_int 1], P.of_int (max_reg+1))] PTree.empty;; - *) + let injections = compute_injections f in + let () = pp_injections stdout injections in + injections;; diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 69b32c7c..587f768e 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -26,11 +26,11 @@ Definition big_endian := false. Definition align_int64 := 8%Z. Definition align_float64 := 8%Z. -Definition splitlong := negb ptr64. +Definition splitlong := false. Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. Proof. - unfold splitlong. destruct ptr64; simpl; congruence. + unfold splitlong. congruence. Qed. (** THIS IS NOT CHECKED ! NONE OF THIS ! *) @@ -77,3 +77,5 @@ Global Opaque ptr64 big_endian splitlong (** Whether to generate position-independent code or not *) Parameter pic_code: unit -> bool. + +Definition has_notrap_loads := true. diff --git a/powerpc/Archi.v b/powerpc/Archi.v index 10f38391..8f96dafc 100644 --- a/powerpc/Archi.v +++ b/powerpc/Archi.v @@ -71,3 +71,5 @@ Global Opaque ptr64 big_endian splitlong default_nan_32 choose_nan_32 fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. + +Definition has_notrap_loads := false. diff --git a/riscV/Archi.v b/riscV/Archi.v index 61d129d0..9bdaad99 100644 --- a/riscV/Archi.v +++ b/riscV/Archi.v @@ -72,3 +72,5 @@ Global Opaque ptr64 big_endian splitlong (** Whether to generate position-independent code or not *) Parameter pic_code: unit -> bool. + +Definition has_notrap_loads := false. diff --git a/test/monniaux/cse2/noloopinvariant.c b/test/monniaux/cse2/noloopinvariant.c new file mode 100644 index 00000000..5c7789bf --- /dev/null +++ b/test/monniaux/cse2/noloopinvariant.c @@ -0,0 +1,6 @@ +int toto(int *t, int n) { + for(int i=1; i t[0]) return i; + } + return 0; +} diff --git a/x86_32/Archi.v b/x86_32/Archi.v index e9d05c14..4681784d 100644 --- a/x86_32/Archi.v +++ b/x86_32/Archi.v @@ -64,3 +64,5 @@ Global Opaque ptr64 big_endian splitlong default_nan_32 choose_nan_32 fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. + +Definition has_notrap_loads := false. diff --git a/x86_64/Archi.v b/x86_64/Archi.v index 959d8dc1..0e3c55f8 100644 --- a/x86_64/Archi.v +++ b/x86_64/Archi.v @@ -64,3 +64,5 @@ Global Opaque ptr64 big_endian splitlong default_nan_32 choose_nan_32 fma_order fma_invalid_mul_is_nan float_of_single_preserves_sNaN. + +Definition has_notrap_loads := false. -- cgit From 22d8683c16e863dc44ef45d66a4530d8c63d2c30 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 20:03:49 +0200 Subject: forgotten extraction --- extraction/extraction.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extraction/extraction.v b/extraction/extraction.v index b102503b..18637336 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -224,4 +224,5 @@ Separate Extraction Floats.Float32.from_parsed Floats.Float.from_parsed Globalenvs.Senv.invert_symbol Parser.translation_unit_file - Compopts.optim_postpass. + Compopts.optim_postpass + Archi.has_notrap_loads. -- cgit From a95735290d61f50a388895ef86627becd67c4553 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 20:04:15 +0200 Subject: activate LICM --- backend/LICMaux.ml | 2 +- driver/Clflags.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 0368b94f..32044cc9 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -247,5 +247,5 @@ let print_loop_headers f = let gen_injections (f : coq_function) (coq_max_pc : node) (coq_max_reg : reg): (Inject.inj_instr list) PTree.t = let injections = compute_injections f in - let () = pp_injections stdout injections in + (* let () = pp_injections stdout injections in *) injections;; diff --git a/driver/Clflags.ml b/driver/Clflags.ml index ae96e820..8deb5224 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -82,6 +82,6 @@ let option_fxsaddr = ref true let option_faddx = ref false let option_fcoalesce_mem = ref true let option_fforward_moves = ref true -let option_fmove_loop_invariants = ref false +let option_fmove_loop_invariants = ref true let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 -- cgit From eead578fde08a1555086ed75714bca3ca1f9b1dc Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Sun, 19 Apr 2020 21:14:21 +0200 Subject: add options for controlling madd and notrap selection --- backend/LICMaux.ml | 3 ++- driver/Clflags.ml | 4 +++- driver/Compopts.v | 3 +++ driver/Driver.ml | 2 ++ extraction/extraction.v | 2 ++ mppa_k1c/SelectOp.vp | 22 ++++++++++++++++------ mppa_k1c/SelectOpproof.v | 27 ++++++++++++++++++--------- 7 files changed, 46 insertions(+), 17 deletions(-) diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 32044cc9..4ebc7844 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -141,7 +141,8 @@ let rewrite_loop_body (last_alloc : reg ref) new_res)); PTree.set res new_res mapper | Iload(trap, chunk, addr, args, res, pc') - when Archi.has_notrap_loads -> + when Archi.has_notrap_loads && + !Clflags.option_fnontrap_loads -> let new_res = P.succ !last_alloc in last_alloc := new_res; add_inj (INJload(chunk, addr, diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 8deb5224..8e3305ef 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -79,9 +79,11 @@ let use_standard_headers = ref Configuration.has_standard_headers let option_fglobaladdrtmp = ref false let option_fglobaladdroffset = ref false let option_fxsaddr = ref true -let option_faddx = ref false +let option_faddx = ref false +let option_fmadd = ref true let option_fcoalesce_mem = ref true let option_fforward_moves = ref true let option_fmove_loop_invariants = ref true +let option_fnontrap_loads = ref true let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 diff --git a/driver/Compopts.v b/driver/Compopts.v index e4dae87d..5acd2640 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -69,6 +69,9 @@ Parameter optim_xsaddr: unit -> bool. (** FIXME TEMPORARY Flag -fcoaelesce-mem. Fuse (default true) *) Parameter optim_coalesce_mem: unit -> bool. +(* FIXME TEMPORARY Flag -faddx. Fuse (default true) *) +Parameter optim_madd: unit -> bool. + (** FIXME TEMPORARY Flag -faddx. Fuse (default false) *) Parameter optim_addx: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index 0f9e637c..6a9e9b92 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -415,6 +415,8 @@ let cmdline_actions = @ f_opt "globaladdroffset" option_fglobaladdroffset @ f_opt "xsaddr" option_fxsaddr @ f_opt "addx" option_faddx + @ f_opt "madd" option_fmadd + @ f_opt "nontrap-loads" option_fnontrap_loads @ f_opt "coalesce-mem" option_fcoalesce_mem @ f_opt "all-loads-nontrap" option_all_loads_nontrap @ f_opt "forward-moves" option_fforward_moves diff --git a/extraction/extraction.v b/extraction/extraction.v index 18637336..b6aa3409 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -142,6 +142,8 @@ Extract Constant Compopts.optim_xsaddr => "fun _ -> !Clflags.option_fxsaddr". Extract Constant Compopts.optim_addx => "fun _ -> !Clflags.option_faddx". +Extract Constant Compopts.optim_madd => + "fun _ -> !Clflags.option_fmadd". Extract Constant Compopts.optim_coalesce_mem => "fun _ -> !Clflags.option_fcoalesce_mem". Extract Constant Compopts.optim_forward_moves => diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index ec3985c5..0974f872 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -168,13 +168,21 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) | t1, (Eop Omul (t2:::t3:::Enil)) => - Eop Omadd (t1:::t2:::t3:::Enil) + if Compopts.optim_madd tt + then Eop Omadd (t1:::t2:::t3:::Enil) + else Eop Oadd (e1:::e2:::Enil) | (Eop Omul (t2:::t3:::Enil)), t1 => - Eop Omadd (t1:::t2:::t3:::Enil) + if Compopts.optim_madd tt + then Eop Omadd (t1:::t2:::t3:::Enil) + else Eop Oadd (e1:::e2:::Enil) | t1, (Eop (Omulimm n) (t2:::Enil)) => - Eop (Omaddimm n) (t1:::t2:::Enil) + if Compopts.optim_madd tt + then Eop (Omaddimm n) (t1:::t2:::Enil) + else Eop Oadd (e1:::e2:::Enil) | (Eop (Omulimm n) (t2:::Enil)), t1 => - Eop (Omaddimm n) (t1:::t2:::Enil) + if Compopts.optim_madd tt + then Eop (Omaddimm n) (t1:::t2:::Enil) + else Eop Oadd (e1:::e2:::Enil) | (Eop (Oshlimm n) (t1:::Enil)), t2 => add_shlimm n t1 t2 | t2, (Eop (Oshlimm n) (t1:::Enil)) => @@ -197,7 +205,9 @@ Nondetfunction sub (e1: expr) (e2: expr) := | t1, (Eop Omul (t2:::t3:::Enil)) => Eop Omsub (t1:::t2:::t3:::Enil) | t1, (Eop (Omulimm n) (t2:::Enil)) => - Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) + if Compopts.optim_madd tt + then Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) + else Eop Osub (e1:::e2:::Enil) | _, _ => Eop Osub (e1:::e2:::Enil) end. @@ -712,4 +722,4 @@ End SELECT. (* Local Variables: *) (* mode: coq *) -(* End: *) \ No newline at end of file +(* End: *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index d3eb1dde..368f78f4 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -350,13 +350,19 @@ Proof. apply eval_addimm. EvalOp. repeat rewrite Val.add_assoc. reflexivity. - (* Omadd *) - subst. TrivialExists. + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). - (* Omadd rev *) - subst. rewrite Val.add_commut. TrivialExists. + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + simpl. rewrite Val.add_commut. reflexivity. - (* Omaddimm *) - subst. TrivialExists. + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). - (* Omaddimm rev *) - subst. rewrite Val.add_commut. TrivialExists. + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + simpl. rewrite Val.add_commut. reflexivity. (* Oaddx *) - subst. pose proof eval_addx as ADDX. unfold binary_constructor_sound in ADDX. @@ -380,11 +386,14 @@ Proof. - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. - TrivialExists. simpl. subst. reflexivity. - - TrivialExists. simpl. subst. - rewrite sub_add_neg. - rewrite neg_mul_distr_r. - unfold Val.neg. - reflexivity. + - destruct (Compopts.optim_madd tt). + + TrivialExists. simpl. subst. + rewrite sub_add_neg. + rewrite neg_mul_distr_r. + unfold Val.neg. + reflexivity. + + TrivialExists. repeat (eauto; econstructor). + simpl. subst. reflexivity. - TrivialExists. Qed. -- cgit From a529539e958f358cad0911cb668723749e565f58 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 14:12:21 +0200 Subject: seems like fixed linking tests?! --- runtime/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/runtime/Makefile b/runtime/Makefile index a689f3ea..5b8f8fdf 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -25,8 +25,8 @@ OBJS=i64_dtou.o i64_stof.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),mppa_k1c) OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o \ i64_udivmod_stsud.o i32_divmod.o \ + i64_utod.o i64_utof.o i64_stod.o i64_stof.o \ vararg.o -# Missing: i64_utod.o i64_utof.o i64_stod.o i64_stof.o DOMAKE:=$(shell (cd mppa_k1c && make)) else ifeq ($(ARCH),aarch64) OBJS=vararg.o -- cgit From 09184b1ab9be700d0cb5125c113b4fb8d6be06c8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 15:16:34 +0200 Subject: fix int64 --- runtime/mppa_k1c/i64_udivmod_stsud.s | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/runtime/mppa_k1c/i64_udivmod_stsud.s b/runtime/mppa_k1c/i64_udivmod_stsud.s index b1d10326..50d0a767 100644 --- a/runtime/mppa_k1c/i64_udivmod_stsud.s +++ b/runtime/mppa_k1c/i64_udivmod_stsud.s @@ -135,6 +135,8 @@ __compcert_i64_udiv_stsud: __compcert_i64_sdiv_stsud: compd.lt $r2 = $r0, 0 compd.lt $r3 = $r1, 0 + absd $r0 = $r0 + absd $r1 = $r1 ;; xord $r2 = $r2, $r3 make $r3 = 0 @@ -144,6 +146,8 @@ __compcert_i64_sdiv_stsud: .globl __compcert_i64_smod_stsud __compcert_i64_smod_stsud: compd.lt $r2 = $r0, 0 + absd $r0 = $r0 + absd $r1 = $r1 make $r3 = 1 goto __compcert_i64_divmod_stsud ;; -- cgit From 9603222d9eeeaface592cbe2c47834faba4ba50f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 15:42:13 +0200 Subject: fix Mandelbrot --- test/c/Results/mandelbrot-mppa_k1c | Bin 409 -> 209 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/test/c/Results/mandelbrot-mppa_k1c b/test/c/Results/mandelbrot-mppa_k1c index f50961fe..55c5683a 100644 Binary files a/test/c/Results/mandelbrot-mppa_k1c and b/test/c/Results/mandelbrot-mppa_k1c differ -- cgit From 1b1274d2b275661e72e01cfbf8332478c673dbca Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 15:42:37 +0200 Subject: no longer missing files --- runtime/Makefile | 1 - 1 file changed, 1 deletion(-) diff --git a/runtime/Makefile b/runtime/Makefile index 3b1cabc4..e3f008a9 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -26,7 +26,6 @@ else ifeq ($(ARCH),mppa_k1c) OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o vararg.o\ i64_dtos.o i64_dtou.o i64_utod.o i64_utof.o i64_stod.o i64_stof.o\ i64_shl.o i64_shr.o -# Missing: i64_utod.o i64_utof.o i64_stod.o i64_stof.o DOMAKE:=$(shell (cd mppa_k1c && make)) else ifeq ($(ARCH),aarch64) OBJS=vararg.o -- cgit From 4965352c558f8e030b3b968f98566f87ed6f0b8a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 18:29:57 +0200 Subject: do not print debug stuff --- backend/Profilingaux.ml | 6 ++++-- runtime/Makefile | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index f8fc5d6b..ec0ae304 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -24,8 +24,10 @@ let print_anonymous_function pp f = let function_id (f : coq_function) : identifier = let digest = Digest.string (Marshal.to_string f []) in + (* Printf.fprintf stderr "FUNCTION hash = %a\n" pp_id digest; print_anonymous_function stderr f; + *) digest let branch_id (f_id : identifier) (node : P.t) : identifier = @@ -65,7 +67,7 @@ let load_profiling_info (filename : string) : unit = let condition_oracle (id : identifier) : bool option = let (count0, count1) = get_counts id in - ( (* if count0 <> 0L || count1 <> 0L then *) - Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1); + (* (if count0 <> 0L || count1 <> 0L then + Printf.fprintf stderr "%a : %Ld %Ld\n" pp_id id count0 count1); *) if count0 = count1 then None else Some(count1 > count0);; diff --git a/runtime/Makefile b/runtime/Makefile index bf979d5f..98cde235 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -1,6 +1,6 @@ include ../Makefile.config -CFLAGS=-O1 -g -Wall +CFLAGS=-O1 -Wall ifeq ($(ARCH),x86) ifeq ($(MODEL),64) -- cgit From ac246d223971e66dd55f79a13d309b93e395ad74 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 19:35:37 +0200 Subject: change semantics for trapping ops --- mppa_k1c/Op.v | 108 +++++++++++++++++++++++++++------------------------------- 1 file changed, 50 insertions(+), 58 deletions(-) diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 92061d04..57c49ef2 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -374,7 +374,7 @@ Definition eval_operation | Ororimm n, v1 :: nil => Some (Val.ror v1 (Vint n)) | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshrximm n, v1::nil => Some (Val.maketotal (Val.shrx v1 (Vint n))) | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) @@ -424,7 +424,7 @@ Definition eval_operation | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) - | Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n) + | Oshrxlimm n, v1::nil => Some (Val.maketotal (Val.shrxl v1 (Vint n))) | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) @@ -454,20 +454,20 @@ Definition eval_operation | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ointofsingle, v1::nil => Val.intofsingle v1 - | Ointuofsingle, v1::nil => Val.intuofsingle v1 - | Osingleofint, v1::nil => Val.singleofint v1 - | Osingleofintu, v1::nil => Val.singleofintu v1 - | Olongoffloat, v1::nil => Val.longoffloat v1 - | Olonguoffloat, v1::nil => Val.longuoffloat v1 - | Ofloatoflong, v1::nil => Val.floatoflong v1 - | Ofloatoflongu, v1::nil => Val.floatoflongu v1 - | Olongofsingle, v1::nil => Val.longofsingle v1 - | Olonguofsingle, v1::nil => Val.longuofsingle v1 - | Osingleoflong, v1::nil => Val.singleoflong v1 - | Osingleoflongu, v1::nil => Val.singleoflongu v1 + | Ointoffloat, v1::nil => Some (Val.maketotal (Val.intoffloat v1)) + | Ointuoffloat, v1::nil => Some (Val.maketotal (Val.intuoffloat v1)) + | Ointofsingle, v1::nil => Some (Val.maketotal (Val.intofsingle v1)) + | Ointuofsingle, v1::nil => Some (Val.maketotal (Val.intuofsingle v1)) + | Osingleofint, v1::nil => Some (Val.maketotal (Val.singleofint v1)) + | Osingleofintu, v1::nil => Some (Val.maketotal (Val.singleofintu v1)) + | Olongoffloat, v1::nil => Some (Val.maketotal (Val.longoffloat v1)) + | Olonguoffloat, v1::nil => Some (Val.maketotal (Val.longuoffloat v1)) + | Ofloatoflong, v1::nil => Some (Val.maketotal (Val.floatoflong v1)) + | Ofloatoflongu, v1::nil => Some (Val.maketotal (Val.floatoflongu v1)) + | Olongofsingle, v1::nil => Some (Val.maketotal (Val.longofsingle v1)) + | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) + | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) + | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) | (Oextfz stop start), v0::nil => Some (extfz stop start v0) | (Oextfs stop start), v0::nil => Some (extfs stop start v0) @@ -840,7 +840,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... (* shrx *) - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0... + - destruct v0; simpl... destruct (Int.ltu n (Int.repr 31)); simpl; trivial. (* shrimm *) - destruct v0; simpl... (* madd *) @@ -920,7 +920,7 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... (* shrxl *) - - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0... + - destruct v0; simpl... destruct (Int.ltu n (Int.repr 63)); simpl; trivial. (* maddl, maddlim *) - apply type_addl. - apply type_addl. @@ -962,26 +962,26 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - destruct v0... - destruct v0... (* intoffloat, intuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2... + - destruct v0; simpl... destruct (Float.to_int f); simpl; trivial. + - destruct v0; simpl... destruct (Float.to_intu f); simpl; trivial. (* intofsingle, intuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2... + - destruct v0; simpl... destruct (Float32.to_int f); simpl; trivial. + - destruct v0; simpl... destruct (Float32.to_intu f); simpl; trivial. (* singleofint, singleofintu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl... + - destruct v0; simpl... (* longoffloat, longuoffloat *) - - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2... + - destruct v0; simpl... destruct (Float.to_long f); simpl; trivial. + - destruct v0; simpl... destruct (Float.to_longu f); simpl; trivial. (* floatoflong, floatoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl... + - destruct v0; simpl... (* longofsingle, longuofsingle *) - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2... - - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2... + - destruct v0; simpl... destruct (Float32.to_long f); simpl; trivial. + - destruct v0; simpl... destruct (Float32.to_longu f); simpl; trivial. (* singleoflong, singleoflongu *) - - destruct v0; simpl in H0; inv H0... - - destruct v0; simpl in H0; inv H0... + - destruct v0; simpl... + - destruct v0; simpl... (* cmp *) - destruct (eval_condition cond vl m)... destruct b... (* extfz *) @@ -1477,8 +1477,8 @@ Proof. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. (* shrx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists. + - inv H4; simpl; auto. + destruct (Int.ltu n (Int.repr 31)); inv H; simpl; auto. (* rorimm *) - inv H4; simpl; auto. (* madd, maddim *) @@ -1567,8 +1567,8 @@ Proof. - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. (* shrx *) - - inv H4; simpl in H1; try discriminate. simpl. - destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists. + - inv H4; simpl; auto. + destruct (Int.ltu n (Int.repr 63)); simpl; auto. (* maddl, maddlimm *) - apply Val.addl_inject; auto. @@ -1615,34 +1615,26 @@ Proof. - inv H4; simpl; auto. - inv H4; simpl; auto. (* intoffloat, intuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; simpl; auto. destruct (Float.to_int f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float.to_intu f0); simpl; auto. (* intofsingle, intuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2. - exists (Vint i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2. - exists (Vint i); auto. + - inv H4; simpl; auto. destruct (Float32.to_int f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float32.to_intu f0); simpl; auto. (* singleofint, singleofintu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl; auto. + - inv H4; simpl; auto. (* longoffloat, longuoffloat *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; simpl; auto. destruct (Float.to_long f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float.to_longu f0); simpl; auto. (* floatoflong, floatoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl; auto. + - inv H4; simpl; auto. (* longofsingle, longuofsingle *) - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2. - exists (Vlong i); auto. - - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2. - exists (Vlong i); auto. + - inv H4; simpl; auto. destruct (Float32.to_long f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float32.to_longu f0); simpl; auto. (* singleoflong, singleoflongu *) - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. - - inv H4; simpl in H1; inv H1. simpl. TrivialExists. + - inv H4; simpl; auto. + - inv H4; simpl; auto. (* cmp *) - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. -- cgit From 7b0089ab6de94f81021c5c3d78aea752d2582253 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 21:10:09 +0200 Subject: adapt VA --- mppa_k1c/ValueAOp.v | 314 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 306 insertions(+), 8 deletions(-) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 7d84447e..901908b5 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -14,6 +14,86 @@ Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. Require Import Op ExtValues ExtFloats RTL ValueDomain. +Definition intoffloat_total (x: aval) := + match x with + | F f => + match Float.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longoffloat_total (x: aval) := + match x with + | F f => + match Float.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + Definition minf := binop_float ExtFloat.min. Definition maxf := binop_float ExtFloat.max. Definition minfs := binop_single ExtFloat32.min. @@ -282,18 +362,18 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval := | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3 | Osingleoffloat, v1::nil => singleoffloat v1 | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat v1 - | Ointuoffloat, v1::nil => intuoffloat v1 - | Ointofsingle, v1::nil => intofsingle v1 - | Ointuofsingle, v1::nil => intuofsingle v1 + | Ointoffloat, v1::nil => intoffloat_total v1 + | Ointuoffloat, v1::nil => intuoffloat_total v1 + | Ointofsingle, v1::nil => intofsingle_total v1 + | Ointuofsingle, v1::nil => intuofsingle_total v1 | Osingleofint, v1::nil => singleofint v1 | Osingleofintu, v1::nil => singleofintu v1 - | Olongoffloat, v1::nil => longoffloat v1 - | Olonguoffloat, v1::nil => longuoffloat v1 + | Olongoffloat, v1::nil => longoffloat_total v1 + | Olonguoffloat, v1::nil => longuoffloat_total v1 | Ofloatoflong, v1::nil => floatoflong v1 | Ofloatoflongu, v1::nil => floatoflongu v1 - | Olongofsingle, v1::nil => longofsingle v1 - | Olonguofsingle, v1::nil => longuofsingle v1 + | Olongofsingle, v1::nil => longofsingle_total v1 + | Olonguofsingle, v1::nil => longuofsingle_total v1 | Osingleoflong, v1::nil => singleoflong v1 | Osingleoflongu, v1::nil => singleoflongu v1 | Ocmp c, _ => of_optbool (eval_static_condition c vl) @@ -317,6 +397,196 @@ Hypothesis GENV: genv_match bc ge. Variable sp: block. Hypothesis STACK: bc sp = BCstack. +Lemma intoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intoffloat_total_sound : va. + +Lemma intuoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intuoffloat_total_sound : va. + +Lemma intofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intofsingle_total_sound : va. + +Lemma intuofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intuofsingle_total_sound : va. + +Lemma singleofint_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleofint v)) (singleofint x). +Proof. + unfold Val.singleofint, singleofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleofint_total_sound : va. + +Lemma singleofintu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleofintu v)) (singleofintu x). +Proof. + unfold Val.singleofintu, singleofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleofintu_total_sound : va. + +Lemma longoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longoffloat_total_sound : va. + +Lemma longuoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longuoffloat_total_sound : va. + +Lemma longofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longofsingle_total_sound : va. + +Lemma longuofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longuofsingle_total_sound : va. + +Lemma singleoflong_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleoflong v)) (singleoflong x). +Proof. + unfold Val.singleoflong, singleoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleoflong_total_sound : va. + +Lemma singleoflongu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). +Proof. + unfold Val.singleoflongu, singleoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleoflongu_total_sound : va. + +Lemma floatoflong_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.floatoflong v)) (floatoflong x). +Proof. + unfold Val.floatoflong, floatoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve floatoflong_total_sound : va. + +Lemma floatoflongu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). +Proof. + unfold Val.floatoflongu, floatoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve floatoflongu_total_sound : va. + Lemma minf_sound: forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). Proof. @@ -490,6 +760,26 @@ Proof. destruct addr; trivial; discriminate. Qed. +Lemma vmatch_vint_ntop1: + forall x y, vmatch bc (Vint x) (ntop1 y). +Proof. + intro. unfold ntop1, provenance. + destruct y; + destruct (va_strict tt); + constructor. +Qed. + +Lemma vmatch_vlong_ntop1: + forall x y, vmatch bc (Vlong x) (ntop1 y). +Proof. + intro. unfold ntop1, provenance. + destruct y; + destruct (va_strict tt); + constructor. +Qed. + +Hint Resolve vmatch_vint_ntop1 vmatch_vlong_ntop1: va. + Theorem eval_static_operation_sound: forall op vargs m vres aargs, eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> @@ -518,6 +808,10 @@ Proof. end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct n; destruct shift; reflexivity. + - (* shrx *) + inv H1; simpl; try constructor. + all: destruct Int.ltu; [simpl | constructor; fail]. + all: auto with va. - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with | Vlong n2 => Vlong (Int64.add n n2) | Vptr b2 ofs2 => @@ -535,6 +829,10 @@ Proof. end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + eauto with va. + destruct a1; destruct shift; reflexivity. + - (* shrxl *) + inv H1; simpl; try constructor. + all: destruct Int.ltu; [simpl | constructor; fail]. + all: auto with va. - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. (* extfz *) -- cgit From 69010f52e11859619c0894f91cdb5840eb4986aa Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 21:12:35 +0200 Subject: detail with shrxl --- mppa_k1c/ConstpropOpproof.v | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v index ae11a220..4dd0441d 100644 --- a/mppa_k1c/ConstpropOpproof.v +++ b/mppa_k1c/ConstpropOpproof.v @@ -276,7 +276,8 @@ Proof. inv H; auto. destruct (Int.is_power2 n) eqn:?. destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence. + exists v; split; auto. simpl. + erewrite Val.divs_pow2; eauto. reflexivity. congruence. exists v; auto. exists v; auto. Qed. @@ -449,7 +450,8 @@ Lemma make_divlimm_correct: Proof. intros; unfold make_divlimm. destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. - rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto. + rewrite H0 in H. econstructor; split. simpl; eauto. + erewrite Val.divls_pow2; eauto. auto. exists v; auto. exists v; auto. Qed. -- cgit From fcf5b5c840f93d8c8b09ba299ab3962f43f080d3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 21:43:32 +0200 Subject: new semantics for some trapping operations --- mppa_k1c/Asmblockgenproof1.v | 2 -- mppa_k1c/Asmvliw.v | 20 ++++++++++---------- mppa_k1c/Op.v | 10 +--------- mppa_k1c/SelectLongproof.v | 33 +++++---------------------------- mppa_k1c/SelectOpproof.v | 40 ++++++++++------------------------------ 5 files changed, 26 insertions(+), 79 deletions(-) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 00df01e3..9c836037 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1535,7 +1535,6 @@ Opaque Int.eq. + apply exec_straight_one. simpl. eauto. + repeat split. * rewrite Pregmap.gss. - subst v. destruct (rs x0); simpl; trivial. unfold Val.maketotal. destruct (Int.ltu _ _); simpl; trivial. @@ -1546,7 +1545,6 @@ Opaque Int.eq. + apply exec_straight_one. simpl. eauto. + repeat split. * rewrite Pregmap.gss. - subst v. destruct (rs x0); simpl; trivial. unfold Val.maketotal. destruct (Int.ltu _ _); simpl; trivial. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 946007c1..819120a0 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -988,16 +988,16 @@ Definition arith_eval_rr n v := | Pfinvw => ExtValues.invfs v | Pfnarrowdw => Val.singleoffloat v | Pfwidenlwd => Val.floatofsingle v - | Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end - | Pfloatuwrnsz => match Val.singleofintu v with Some f => f | _ => Vundef end - | Pfloatudrnsz => match Val.floatoflongu v with Some f => f | _ => Vundef end - | Pfloatdrnsz => match Val.floatoflong v with Some f => f | _ => Vundef end - | Pfixedwrzz => match Val.intofsingle v with Some i => i | _ => Vundef end - | Pfixeduwrzz => match Val.intuofsingle v with Some i => i | _ => Vundef end - | Pfixeddrzz => match Val.longoffloat v with Some i => i | _ => Vundef end - | Pfixedudrzz => match Val.longuoffloat v with Some i => i | _ => Vundef end - | Pfixeddrzz_i32 => match Val.intoffloat v with Some i => i | _ => Vundef end - | Pfixedudrzz_i32 => match Val.intuoffloat v with Some i => i | _ => Vundef end + | Pfloatwrnsz => Val.maketotal (Val.singleofint v) + | Pfloatuwrnsz => Val.maketotal (Val.singleofintu v) + | Pfloatudrnsz => Val.maketotal (Val.floatoflongu v) + | Pfloatdrnsz => Val.maketotal (Val.floatoflong v) + | Pfixedwrzz => Val.maketotal (Val.intofsingle v) + | Pfixeduwrzz => Val.maketotal (Val.intuofsingle v) + | Pfixeddrzz => Val.maketotal (Val.longoffloat v) + | Pfixedudrzz => Val.maketotal (Val.longuoffloat v) + | Pfixeddrzz_i32 => Val.maketotal (Val.intoffloat v) + | Pfixedudrzz_i32 => Val.maketotal (Val.intuoffloat v) end. Definition arith_eval_ri32 n i := diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 57c49ef2..4e874ca8 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1033,15 +1033,7 @@ Qed. Definition is_trapping_op (op : operation) := match op with | Odiv | Odivl | Odivu | Odivlu - | Omod | Omodl | Omodu | Omodlu - | Oshrximm _ | Oshrxlimm _ - | Ointoffloat | Ointuoffloat - | Ointofsingle | Ointuofsingle - | Olongoffloat | Olonguoffloat - | Olongofsingle | Olonguofsingle - | Osingleofint | Osingleofintu - | Osingleoflong | Osingleoflongu - | Ofloatoflong | Ofloatoflongu => true + | Omod | Omodl | Omodu | Omodlu => true | _ => false end. diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index ada02585..5e4f3ed6 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -838,34 +838,7 @@ Proof. + predSpec Int.eq Int.eq_spec n Int.zero. - subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. -- TrivialExists. -(* - intros. unfold shrxlimm. destruct Archi.splitlong eqn:SL. -+ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. -+ destruct x; simpl in H0; try discriminate. - destruct (Int.ltu n (Int.repr 63)) eqn:LTU; inv H0. - predSpec Int.eq Int.eq_spec n Int.zero. - - subst n. exists (Vlong i); split; auto. rewrite Int64.shrx'_zero. auto. - - assert (NZ: Int.unsigned n <> 0). - { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } - assert (LT: 0 <= Int.unsigned n < 63) by (apply Int.ltu_inv in LTU; assumption). - assert (LTU2: Int.ltu (Int.sub Int64.iwordsize' n) Int64.iwordsize' = true). - { unfold Int.ltu; apply zlt_true. - unfold Int.sub. change (Int.unsigned Int64.iwordsize') with 64. - rewrite Int.unsigned_repr. omega. - assert (64 < Int.max_unsigned) by reflexivity. omega. } - assert (X: eval_expr ge sp e m le - (Eop (Oshrlimm (Int.repr (Int64.zwordsize - 1))) (a ::: Enil)) - (Vlong (Int64.shr' i (Int.repr (Int64.zwordsize - 1))))). - { EvalOp. } - assert (Y: eval_expr ge sp e m le (shrxlimm_inner a n) - (Vlong (Int64.shru' (Int64.shr' i (Int.repr (Int64.zwordsize - 1))) (Int.sub Int64.iwordsize' n)))). - { EvalOp. simpl. rewrite LTU2. auto. } - TrivialExists. - constructor. EvalOp. simpl; eauto. constructor. - simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int64.shrx'_shr_2 by auto. reflexivity. - change (Int.unsigned Int64.iwordsize') with 64; omega. -*) +- TrivialExists. simpl. rewrite H0. reflexivity. Qed. Theorem eval_cmplu: @@ -915,6 +888,7 @@ Proof. unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longoffloat; eauto. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. @@ -922,6 +896,7 @@ Proof. unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_longuoffloat; eauto. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. @@ -929,6 +904,7 @@ Proof. unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_floatoflong; eauto. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. @@ -936,6 +912,7 @@ Proof. unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. eapply SplitLongproof.eval_floatoflongu; eauto. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index d3eb1dde..23d2d5b7 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -990,34 +990,8 @@ Proof. replace (Int.shrx i Int.zero) with i. auto. unfold Int.shrx, Int.divs. rewrite Int.shl_zero. change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. - econstructor; split. EvalOp. auto. -(* - intros. destruct x; simpl in H0; try discriminate. - destruct (Int.ltu n (Int.repr 31)) eqn:LTU; inv H0. - unfold shrximm. - predSpec Int.eq Int.eq_spec n Int.zero. - - subst n. exists (Vint i); split; auto. - unfold Int.shrx, Int.divs. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto. - - assert (NZ: Int.unsigned n <> 0). - { intro EQ; elim H0. rewrite <- (Int.repr_unsigned n). rewrite EQ; auto. } - assert (LT: 0 <= Int.unsigned n < 31) by (apply Int.ltu_inv in LTU; assumption). - assert (LTU2: Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true). - { unfold Int.ltu; apply zlt_true. - unfold Int.sub. change (Int.unsigned Int.iwordsize) with 32. - rewrite Int.unsigned_repr. omega. - assert (32 < Int.max_unsigned) by reflexivity. omega. } - assert (X: eval_expr ge sp e m le - (Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) (a ::: Enil)) - (Vint (Int.shr i (Int.repr (Int.zwordsize - 1))))). - { EvalOp. } - assert (Y: eval_expr ge sp e m le (shrximm_inner a n) - (Vint (Int.shru (Int.shr i (Int.repr (Int.zwordsize - 1))) (Int.sub Int.iwordsize n)))). - { EvalOp. simpl. rewrite LTU2. auto. } - TrivialExists. - constructor. EvalOp. simpl; eauto. constructor. - simpl. unfold Int.ltu; rewrite zlt_true. rewrite Int.shrx_shr_2 by auto. reflexivity. - change (Int.unsigned Int.iwordsize) with 32; omega. -*) + econstructor; split. EvalOp. + simpl. rewrite H0. simpl. reflexivity. auto. Qed. Theorem eval_shl: binary_constructor_sound shl Val.shl. @@ -1228,6 +1202,7 @@ Theorem eval_intoffloat: exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold intoffloat. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_intuoffloat: @@ -1237,6 +1212,7 @@ Theorem eval_intuoffloat: exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. Proof. intros; unfold intuoffloat. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_floatofintu: @@ -1256,7 +1232,7 @@ Proof. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. - destruct x; simpl; trivial. + destruct x; simpl; trivial; try discriminate. f_equal. inv H0. f_equal. @@ -1280,7 +1256,7 @@ Proof. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. - destruct x; simpl; trivial. + destruct x; simpl; trivial; try discriminate. f_equal. inv H0. f_equal. @@ -1295,6 +1271,7 @@ Theorem eval_intofsingle: exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold intofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_singleofint: @@ -1304,6 +1281,7 @@ Theorem eval_singleofint: exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. Proof. intros; unfold singleofint; TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_intuofsingle: @@ -1313,6 +1291,7 @@ Theorem eval_intuofsingle: exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. Proof. intros; unfold intuofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_singleofintu: @@ -1322,6 +1301,7 @@ Theorem eval_singleofintu: exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. Proof. intros; unfold intuofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. Qed. Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. -- cgit From adb864a2a9e607f45e73c518f267264fdb570a19 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Mon, 20 Apr 2020 23:51:53 +0200 Subject: forward moves into store source --- backend/CSE2.v | 6 +++--- backend/CSE2proof.v | 5 ++++- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/backend/CSE2.v b/backend/CSE2.v index d9fe5799..dabbaa22 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -389,10 +389,10 @@ Definition apply_external_call ef (rel : RELATION.t) : RELATION.t := | Some bf => rel | None => kill_mem rel end - | EF_malloc (* FIXME *) + | EF_malloc (* would need lessdef *) | EF_external _ _ | EF_vstore _ - | EF_free (* FIXME *) + | EF_free (* would need lessdef? *) | EF_memcpy _ _ (* FIXME *) | EF_inline_asm _ _ _ => kill_mem rel | _ => rel @@ -476,7 +476,7 @@ Definition transf_instr (fmap : option (PMap.t RB.t)) | Some src => Iop Omove (src::nil) dst s end | Istore chunk addr args src s => - Istore chunk addr (subst_args fmap pc args) src s + Istore chunk addr (subst_args fmap pc args) (subst_arg fmap pc src) s | Icall sig ros args dst s => Icall sig ros (subst_args fmap pc args) dst s | Itailcall sig ros args => diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index 9e0ad909..f9c7b400 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1527,7 +1527,10 @@ Proof. assert (eval_addressing tge sp addr rs ## args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. eapply exec_Istore; eauto. - rewrite (subst_args_ok' sp m); assumption. + - rewrite (subst_args_ok' sp m) by assumption. + eassumption. + - rewrite (subst_arg_ok' sp m) by assumption. + eassumption. } constructor; auto. -- cgit From d10bc429a5c08a25471e3f65e328f5cee12e4542 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 Apr 2020 09:35:30 +0200 Subject: forward moves through CSE3 store --- backend/CSE3.v | 2 +- backend/CSE3analysis.v | 4 ++-- backend/CSE3analysisproof.v | 8 ++++---- backend/CSE3proof.v | 5 ++++- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/backend/CSE3.v b/backend/CSE3.v index 352cc895..2203ad14 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -57,7 +57,7 @@ Definition transf_instr (fmap : PMap.t RB.t) | Some src => Iop Omove (src::nil) dst s end | Istore chunk addr args src s => - Istore chunk addr (subst_args fmap pc args) src s + Istore chunk addr (subst_args fmap pc args) (subst_arg fmap pc src) s | Icall sig ros args dst s => Icall sig ros (subst_args fmap pc args) dst s | Itailcall sig ros args => diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index bc5d3244..d3d1c043 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -323,7 +323,7 @@ Section OPERATIONS. (chunk : memory_chunk) (addr: addressing) (args : list reg) (src : reg) (ty: typ) (rel : RELATION.t) : RELATION.t := - store1 chunk addr (forward_move_l rel args) src ty rel. + store1 chunk addr (forward_move_l rel args) (forward_move rel src) ty rel. Definition kill_builtin_res res rel := match res with @@ -354,7 +354,7 @@ Section OPERATIONS. | Icond _ _ _ _ _ | Ijumptable _ _ => Some rel | Istore chunk addr args src _ => - Some (store chunk addr args src (tenv src) rel) + Some (store chunk addr args src (tenv (forward_move rel src)) rel) | Iop op args dst _ => Some (oper dst (SOp op) args rel) | Iload trap chunk addr args dst _ => Some (oper dst (SLoad chunk addr) args rel) | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel)) diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index f4ec7a10..e1e9f6cc 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -848,14 +848,14 @@ Section SOUNDNESS. Qed. Hint Resolve store1_sound : cse3. - + Theorem store_sound: forall no chunk addr args a src rel tenv rs m m', sem_rel rel rs m -> wt_regset tenv rs -> eval_addressing genv sp addr (rs ## args) = Some a -> Mem.storev chunk m a (rs#src) = Some m' -> - sem_rel (store (ctx:=ctx) no chunk addr args src (tenv src) rel) rs m'. + sem_rel (store (ctx:=ctx) no chunk addr args src (tenv (forward_move (ctx:=ctx) rel src)) rel) rs m'. Proof. unfold store. intros until m'. @@ -863,8 +863,8 @@ Section SOUNDNESS. rewrite <- forward_move_l_sound with (rel:=rel) (m:=m) in ADDR by trivial. rewrite <- forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. apply store1_sound with (a := a) (m := m); trivial. - rewrite forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. - assumption. + (* rewrite forward_move_sound with (rel:=rel) (m:=m) in STORE by trivial. + assumption. *) Qed. Hint Resolve store_sound : cse3. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index 53872e62..ccbfd198 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -689,10 +689,13 @@ Proof. - (* Istore *) exists (State ts tf sp pc' rs m'). split. - + eapply exec_Istore with (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)); try eassumption. + + eapply exec_Istore with (args := (subst_args (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc args)) + (src := (subst_arg (ctx:=(context_from_hints (snd (preanalysis tenv f)))) (fst (preanalysis tenv f)) pc src)) ; try eassumption. * TR_AT. reflexivity. * rewrite subst_args_ok with (sp:=sp) (m:=m) by trivial. rewrite eval_addressing_preserved with (ge1 := ge) by exact symbols_preserved. + eassumption. + * rewrite subst_arg_ok with (sp:=sp) (m:=m) by trivial. assumption. + econstructor; eauto. IND_STEP. -- cgit From 14388a6be6cf7aac50f2af4ff29fe9726ad83435 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 Apr 2020 18:04:43 +0200 Subject: improvement in precision --- backend/CSE3analysis.v | 4 +++- backend/CSE3analysisproof.v | 36 +++++++++++++++++++++++++++++++----- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index d3d1c043..b495371d 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -64,6 +64,7 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. Qed. Definition lub := PSet.inter. + Definition glb := PSet.union. Lemma ge_lub_left: forall x y, ge (lub x y) x. Proof. @@ -274,7 +275,8 @@ Section OPERATIONS. Definition oper (dst : reg) (op: sym_op) (args : list reg) (rel : RELATION.t) : RELATION.t := match rhs_find op (forward_move_l rel args) rel with - | Some r => move r dst rel + | Some r => RELATION.glb (move r dst rel) + (oper1 dst op args rel) | None => oper1 dst op args rel end. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index e1e9f6cc..3ea5e078 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -361,6 +361,30 @@ Section SOUNDNESS. eq_catalog ctx i = Some eq -> sem_eq eq rs m. + Lemma sem_rel_glb: + forall rel1 rel2 rs m, + (sem_rel (RELATION.glb rel1 rel2) rs m) <-> + ((sem_rel rel1 rs m) /\ + (sem_rel rel2 rs m)). + Proof. + intros. + unfold sem_rel, RELATION.glb. + split. + - intro IMPLIES. + split; + intros i eq CONTAINS; + specialize IMPLIES with (i:=i) (eq0:=eq); + rewrite PSet.gunion in IMPLIES; + rewrite orb_true_iff in IMPLIES; + intuition. + - intros (IMPLIES1 & IMPLIES2) i eq. + rewrite PSet.gunion. + rewrite orb_true_iff. + specialize IMPLIES1 with (i:=i) (eq0:=eq). + specialize IMPLIES2 with (i:=i) (eq0:=eq). + intuition. + Qed. + Hypothesis ctx_kill_reg_has_lhs : forall lhs sop args j, eq_catalog ctx j = Some {| eq_lhs := lhs; @@ -755,11 +779,13 @@ Section SOUNDNESS. intros REL RHS. unfold oper. destruct rhs_find as [src |] eqn:RHS_FIND. - - pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. - eapply forward_move_rhs_sound in RHS. - 2: eassumption. - rewrite <- (sem_rhs_det SOUND RHS). - apply move_sound; auto. + - apply sem_rel_glb; split. + + pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. + eapply forward_move_rhs_sound in RHS. + 2: eassumption. + rewrite <- (sem_rhs_det SOUND RHS). + apply move_sound; auto. + + apply oper1_sound; auto. - apply oper1_sound; auto. Qed. -- cgit From e7ce7b5c9cf0d03c8ffdde8fe433e586142821a6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 Apr 2020 18:15:13 +0200 Subject: example --- test/monniaux/licm/addv.c | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 test/monniaux/licm/addv.c diff --git a/test/monniaux/licm/addv.c b/test/monniaux/licm/addv.c new file mode 100644 index 00000000..bb0098d0 --- /dev/null +++ b/test/monniaux/licm/addv.c @@ -0,0 +1,6 @@ +void addv(double x, double y, int n, int *z) +{ + for(int i=0; i Date: Tue, 21 Apr 2020 22:08:07 +0200 Subject: begin scripting the Compiler.v file --- Makefile | 5 + backend/Unusedglob.v | 2 +- backend/Unusedglobproof.v | 4 +- driver/Compiler.v | 568 ---------------------------------------------- driver/Compiler.vexpand | 533 +++++++++++++++++++++++++++++++++++++++++++ tools/compiler_expand.ml | 62 +++++ 6 files changed, 603 insertions(+), 571 deletions(-) delete mode 100644 driver/Compiler.v create mode 100644 driver/Compiler.vexpand create mode 100644 tools/compiler_expand.ml diff --git a/Makefile b/Makefile index a69f7e2e..2f9ab029 100644 --- a/Makefile +++ b/Makefile @@ -201,6 +201,8 @@ tools/ndfun: tools/ndfun.ml ocamlopt -o tools/ndfun str.cmxa tools/ndfun.ml tools/modorder: tools/modorder.ml ocamlopt -o tools/modorder str.cmxa tools/modorder.ml +tools/compiler_expand: tools/compiler_expand.ml + ocamlopt -o $@ $+ latexdoc: cd doc; $(COQDOC) --latex -o doc/doc.tex -g $(FILES) @@ -216,6 +218,9 @@ latexdoc: @tools/ndfun $*.vp > $*.v || { rm -f $*.v; exit 2; } @chmod a-w $*.v +driver/Compiler.v: driver/Compiler.vexpand tools/compiler_expand + tools/compiler_expand driver/Compiler.vexpand $@ + compcert.ini: Makefile.config (echo "stdlib_path=$(LIBDIR)"; \ echo "prepro=$(CPREPRO)"; \ diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 93ca7af4..3b8e19ad 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -126,7 +126,7 @@ Fixpoint filter_globdefs (used: IS.t) (accu defs: list (ident * globdef fundef u Definition global_defined (p: program) (pm: prog_map) (id: ident) : bool := match pm!id with Some _ => true | None => ident_eq id (prog_main p) end. -Definition transform_program (p: program) : res program := +Definition transf_program (p: program) : res program := let pm := prog_defmap p in match used_globals p pm with | None => Error (msg "Unusedglob: analysis failed") diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index fa120b6d..160c0b18 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -428,9 +428,9 @@ Qed. End TRANSFORMATION. Theorem transf_program_match: - forall p tp, transform_program p = OK tp -> match_prog p tp. + forall p tp, transf_program p = OK tp -> match_prog p tp. Proof. - unfold transform_program; intros p tp TR. set (pm := prog_defmap p) in *. + unfold transf_program; intros p tp TR. set (pm := prog_defmap p) in *. destruct (used_globals p pm) as [u|] eqn:U; try discriminate. destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. exists u; split. diff --git a/driver/Compiler.v b/driver/Compiler.v deleted file mode 100644 index 69041ab0..00000000 --- a/driver/Compiler.v +++ /dev/null @@ -1,568 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** The whole compiler and its proof of semantic preservation *) - -(** Libraries. *) -Require Import String. -Require Import Coqlib Errors. -Require Import AST Linking Smallstep. -(** Languages (syntax and semantics). *) -Require Ctypes Csyntax Csem Cstrategy Cexec. -Require Clight. -Require Csharpminor. -Require Cminor. -Require CminorSel. -Require RTL. -Require LTL. -Require Linear. -Require Mach. -Require Asm. -(** Translation passes. *) -Require Initializers. -Require SimplExpr. -Require SimplLocals. -Require Cshmgen. -Require Cminorgen. -Require Selection. -Require RTLgen. -Require Tailcall. -Require Inlining. -Require Profiling. -Require ProfilingExploit. -Require FirstNop. -Require Renumber. -Require Duplicate. -Require Constprop. -Require LICM. -Require CSE. -Require ForwardMoves. -Require CSE2. -Require CSE3. -Require Deadcode. -Require Unusedglob. -Require Allnontrap. -Require Allocation. -Require Tunneling. -Require Linearize. -Require CleanupLabels. -Require Debugvar. -Require Stacking. -Require Asmgen. -(** Proofs of semantic preservation. *) -Require SimplExprproof. -Require SimplLocalsproof. -Require Cshmgenproof. -Require Cminorgenproof. -Require Selectionproof. -Require RTLgenproof. -Require Tailcallproof. -Require Inliningproof. -Require Profilingproof. -Require ProfilingExploitproof. -Require FirstNopproof. -Require Renumberproof. -Require Duplicateproof. -Require Constpropproof. -Require LICMproof. -Require CSEproof. -Require ForwardMovesproof. -Require CSE2proof. -Require CSE3proof. -Require Deadcodeproof. -Require Unusedglobproof. -Require Allnontrapproof. -Require Allocproof. -Require Tunnelingproof. -Require Linearizeproof. -Require CleanupLabelsproof. -Require Debugvarproof. -Require Stackingproof. -Require Import Asmgenproof. -(** Command-line flags. *) -Require Import Compopts. - -(** Pretty-printers (defined in Caml). *) -Parameter print_Clight: Clight.program -> unit. -Parameter print_Cminor: Cminor.program -> unit. -Parameter print_RTL: Z -> RTL.program -> unit. -Parameter print_LTL: LTL.program -> unit. -Parameter print_Mach: Mach.program -> unit. - -Local Open Scope string_scope. - -(** * Composing the translation passes *) - -(** We first define useful monadic composition operators, - along with funny (but convenient) notations. *) - -Definition apply_total (A B: Type) (x: res A) (f: A -> B) : res B := - match x with Error msg => Error msg | OK x1 => OK (f x1) end. - -Definition apply_partial (A B: Type) - (x: res A) (f: A -> res B) : res B := - match x with Error msg => Error msg | OK x1 => f x1 end. - -Notation "a @@@ b" := - (apply_partial _ _ a b) (at level 50, left associativity). -Notation "a @@ b" := - (apply_total _ _ a b) (at level 50, left associativity). - -Definition print {A: Type} (printer: A -> unit) (prog: A) : A := - let unused := printer prog in prog. - -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. - -Definition total_if {A: Type} - (flag: unit -> bool) (f: A -> A) (prog: A) : A := - if flag tt then f prog else prog. - -Definition partial_if {A: Type} - (flag: unit -> bool) (f: A -> res A) (prog: A) : res A := - if flag tt then f prog else OK prog. - -(** We define three translation functions for whole programs: one - starting with a C program, one with a Cminor program, one with an - RTL program. The three translations produce Asm programs ready for - pretty-printing and assembling. *) - -Definition transf_rtl_program (f: RTL.program) : res Asm.program := - OK f - @@ print (print_RTL 0) - @@ total_if Compopts.optim_tailcalls (time "Tail calls" Tailcall.transf_program) - @@ print (print_RTL 1) - @@@ time "Inlining" Inlining.transf_program - @@ print (print_RTL 2) - @@ total_if Compopts.profile_arcs (time "Profiling insertion" Profiling.transf_program) - @@ print (print_RTL 3) - @@ total_if Compopts.branch_probabilities (time "Profiling use" ProfilingExploit.transf_program) - @@ print (print_RTL 4) - @@ total_if Compopts.optim_move_loop_invariants (time "Inserting initial nop" FirstNop.transf_program) - @@ print (print_RTL 5) - @@ time "Renumbering" Renumber.transf_program - @@ print (print_RTL 6) - @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program) - @@ print (print_RTL 7) - @@ time "Renumbering pre constprop" Renumber.transf_program - @@ print (print_RTL 8) - @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program) - @@ print (print_RTL 9) - @@@ partial_if Compopts.optim_move_loop_invariants (time "LICM" LICM.transf_program) - @@ print (print_RTL 10) - @@ total_if Compopts.optim_move_loop_invariants (time "Renumbering pre CSE" Renumber.transf_program) - @@ print (print_RTL 11) - @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program) - @@ print (print_RTL 12) - @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program) - @@ print (print_RTL 13) - @@@ partial_if Compopts.optim_CSE3 (time "CSE3" CSE3.transf_program) - @@ print (print_RTL 14) - @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program - @@ print (print_RTL 15) - @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program) - @@ print (print_RTL 16) - @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program - @@ print (print_RTL 17) - @@@ time "Unused globals" Unusedglob.transform_program - @@ print (print_RTL 18) - @@@ time "Register allocation" Allocation.transf_program - @@ print print_LTL - @@ time "Branch tunneling" Tunneling.tunnel_program - @@@ time "CFG linearization" Linearize.transf_program - @@ time "Label cleanup" CleanupLabels.transf_program - @@@ partial_if Compopts.debug (time "Debugging info for local variables" Debugvar.transf_program) - @@@ time "Mach generation" Stacking.transf_program - @@ print print_Mach - @@@ time "Total Mach->Asm generation" Asmgen.transf_program. - -Definition transf_cminor_program (p: Cminor.program) : res Asm.program := - OK p - @@ print print_Cminor - @@@ time "Instruction selection" Selection.sel_program - @@@ time "RTL generation" RTLgen.transl_program - @@@ transf_rtl_program. - -Definition transf_clight_program (p: Clight.program) : res Asm.program := - OK p - @@ print print_Clight - @@@ time "Simplification of locals" SimplLocals.transf_program - @@@ time "C#minor generation" Cshmgen.transl_program - @@@ time "Cminor generation" Cminorgen.transl_program - @@@ transf_cminor_program. - -Definition transf_c_program (p: Csyntax.program) : res Asm.program := - OK p - @@@ time "Clight generation" SimplExpr.transl_program - @@@ transf_clight_program. - -(** Force [Initializers] and [Cexec] to be extracted as well. *) - -Definition transl_init := Initializers.transl_init. -Definition cexec_do_step := Cexec.do_step. - -(** The following lemmas help reason over compositions of passes. *) - -Lemma print_identity: - forall (A: Type) (printer: A -> unit) (prog: A), - print printer prog = prog. -Proof. - intros; unfold print. destruct (printer prog); auto. -Qed. - -Lemma compose_print_identity: - forall (A: Type) (x: res A) (f: A -> unit), - x @@ print f = x. -Proof. - intros. destruct x; simpl. rewrite print_identity. auto. auto. -Qed. - -(** * Relational specification of compilation *) - -Definition match_if {A: Type} (flag: unit -> bool) (R: A -> A -> Prop): A -> A -> Prop := - if flag tt then R else eq. - -Lemma total_if_match: - forall (A: Type) (flag: unit -> bool) (f: A -> A) (rel: A -> A -> Prop) (prog: A), - (forall p, rel p (f p)) -> - match_if flag rel prog (total_if flag f prog). -Proof. - intros. unfold match_if, total_if. destruct (flag tt); auto. -Qed. - -Lemma partial_if_match: - forall (A: Type) (flag: unit -> bool) (f: A -> res A) (rel: A -> A -> Prop) (prog tprog: A), - (forall p tp, f p = OK tp -> rel p tp) -> - partial_if flag f prog = OK tprog -> - match_if flag rel prog tprog. -Proof. - intros. unfold match_if, partial_if in *. destruct (flag tt). auto. congruence. -Qed. - -Instance TransfIfLink {A: Type} {LA: Linker A} - (flag: unit -> bool) (transf: A -> A -> Prop) (TL: TransfLink transf) - : TransfLink (match_if flag transf). -Proof. - unfold match_if. destruct (flag tt). -- auto. -- red; intros. subst tp1 tp2. exists p; auto. -Qed. - -(** This is the list of compilation passes of CompCert in relational style. - Each pass is characterized by a [match_prog] relation between its - input code and its output code. The [mkpass] and [:::] combinators, - defined in module [Linking], ensure that the passes are composable - (the output language of a pass is the input language of the next pass) - and that they commute with linking (property [TransfLink], inferred - by the type class mechanism of Coq). *) - -Local Open Scope linking_scope. - -Definition CompCert's_passes := - mkpass SimplExprproof.match_prog - ::: mkpass SimplLocalsproof.match_prog - ::: mkpass Cshmgenproof.match_prog - ::: mkpass Cminorgenproof.match_prog - ::: mkpass Selectionproof.match_prog - ::: mkpass RTLgenproof.match_prog - ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) - ::: mkpass Inliningproof.match_prog - ::: mkpass (match_if Compopts.profile_arcs Profilingproof.match_prog) - ::: mkpass (match_if Compopts.branch_probabilities ProfilingExploitproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants FirstNopproof.match_prog) - ::: mkpass Renumberproof.match_prog - ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) - ::: mkpass Renumberproof.match_prog - ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE3 CSE3proof.match_prog) - ::: mkpass (match_if Compopts.optim_forward_moves ForwardMovesproof.match_prog) - ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) - ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog) - ::: mkpass Unusedglobproof.match_prog - ::: mkpass Allocproof.match_prog - ::: mkpass Tunnelingproof.match_prog - ::: mkpass Linearizeproof.match_prog - ::: mkpass CleanupLabelsproof.match_prog - ::: mkpass (match_if Compopts.debug Debugvarproof.match_prog) - ::: mkpass Stackingproof.match_prog - ::: mkpass Asmgenproof.match_prog - ::: pass_nil _. - -(** Composing the [match_prog] relations above, we obtain the relation - between CompCert C sources and Asm code that characterize CompCert's - compilation. *) - -Definition match_prog: Csyntax.program -> Asm.program -> Prop := - pass_match (compose_passes CompCert's_passes). - -(** The [transf_c_program] function, when successful, produces - assembly code that is in the [match_prog] relation with the source C program. *) - -Theorem transf_c_program_match: - forall p tp, - transf_c_program p = OK tp -> - match_prog p tp. -Proof. - intros p tp T. - unfold transf_c_program, time in T. simpl in T. - destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. - unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. - destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. - destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. - unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. - destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. - set (p8bis := total_if profile_arcs Profiling.transf_program p8) in *. - set (p8ter := total_if branch_probabilities ProfilingExploit.transf_program p8bis) in *. - set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8ter) in *. - set (p9bis := Renumber.transf_program p9) in *. - destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. - set (p11 := Renumber.transf_program p10) in *. - set (p12 := total_if optim_constprop Constprop.transf_program p11) in *. - destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. - set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. - destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. - set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. - set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. - set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. - set (p17 := Tunneling.tunnel_program p16) in *. - destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. - set (p19 := CleanupLabels.transf_program p18) in *. - destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. - destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. - unfold match_prog; simpl. - exists p1; split. apply SimplExprproof.transf_program_match; auto. - exists p2; split. apply SimplLocalsproof.match_transf_program; auto. - exists p3; split. apply Cshmgenproof.transf_program_match; auto. - exists p4; split. apply Cminorgenproof.transf_program_match; auto. - exists p5; split. apply Selectionproof.transf_program_match; auto. - exists p6; split. apply RTLgenproof.transf_program_match; auto. - exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. - exists p8; split. apply Inliningproof.transf_program_match; auto. - exists p8bis; split. apply total_if_match. apply Profilingproof.transf_program_match; auto. - exists p8ter; split. apply total_if_match. apply ProfilingExploitproof.transf_program_match; auto. - exists p9; split. apply total_if_match. apply FirstNopproof.transf_program_match. - exists p9bis; split. apply Renumberproof.transf_program_match. - exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. - exists p11; split. apply Renumberproof.transf_program_match. - exists p12; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p12bis; split. eapply partial_if_match; eauto. apply LICMproof.transf_program_match. - exists p12ter; split. apply total_if_match; eauto. apply Renumberproof.transf_program_match. - exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. - exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. - exists p13ter; split. eapply partial_if_match; eauto. apply CSE3proof.transf_program_match. - exists p13quater; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. - exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. - exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match. - exists p15; split. apply Unusedglobproof.transf_program_match; auto. - exists p16; split. apply Allocproof.transf_program_match; auto. - exists p17; split. apply Tunnelingproof.transf_program_match. - exists p18; split. apply Linearizeproof.transf_program_match; auto. - exists p19; split. apply CleanupLabelsproof.transf_program_match; auto. - exists p20; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. - exists p21; split. apply Stackingproof.transf_program_match; auto. - exists tp; split. apply Asmgenproof.transf_program_match; auto. - reflexivity. -Qed. - -(** * Semantic preservation *) - -(** We now prove that the whole CompCert compiler (as characterized by the - [match_prog] relation) preserves semantics by constructing - the following simulations: -- Forward simulations from [Cstrategy] to [Asm] - (composition of the forward simulations for each pass). -- Backward simulations for the same languages - (derived from the forward simulation, using receptiveness of the source - language and determinacy of [Asm]). -- Backward simulation from [Csem] to [Asm] - (composition of two backward simulations). -*) - -Remark forward_simulation_identity: - forall sem, forward_simulation sem sem. -Proof. - intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. -- auto. -- exists s1; auto. -- subst s2; auto. -- subst s2. exists s1'; auto. -Qed. - -Lemma match_if_simulation: - forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (transf: A -> A -> Prop) (prog tprog: A), - match_if flag transf prog tprog -> - (forall p tp, transf p tp -> forward_simulation (sem p) (sem tp)) -> - forward_simulation (sem prog) (sem tprog). -Proof. - intros. unfold match_if in *. destruct (flag tt). eauto. subst. apply forward_simulation_identity. -Qed. - -Theorem cstrategy_semantic_preservation: - forall p tp, - match_prog p tp -> - forward_simulation (Cstrategy.semantics p) (Asm.semantics tp) - /\ backward_simulation (atomic (Cstrategy.semantics p)) (Asm.semantics tp). -Proof. - intros p tp M. unfold match_prog, pass_match in M; simpl in M. -Ltac DestructM := - match goal with - [ H: exists p, _ /\ _ |- _ ] => - let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in - destruct H as (p & M & MM); clear H - end. - repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p31)). - { - eapply compose_forward_simulations. - eapply SimplExprproof.transl_program_correct; eassumption. - eapply compose_forward_simulations. - eapply SimplLocalsproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Cshmgenproof.transl_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Cminorgenproof.transl_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Selectionproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply RTLgenproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. - eapply compose_forward_simulations. - eapply Inliningproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Profilingproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact ProfilingExploitproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact FirstNopproof.transf_program_correct. - eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. - eapply compose_forward_simulations. - eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. - eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact LICMproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSE2proof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSE3proof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact ForwardMovesproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Allnontrapproof.transf_program_correct. - eapply compose_forward_simulations. - eapply Unusedglobproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Allocproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Tunnelingproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Linearizeproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply CleanupLabelsproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Debugvarproof.transf_program_correct. - eapply compose_forward_simulations. - eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof0.return_address_offset). - exact Asmgenproof.return_address_exists. - eassumption. - eapply Asmgenproof.transf_program_correct; eassumption. - } - split. auto. - apply forward_to_backward_simulation. - apply factor_forward_simulation. auto. eapply sd_traces. eapply Asm.semantics_determinate. - apply atomic_receptive. apply Cstrategy.semantics_strongly_receptive. - apply Asm.semantics_determinate. -Qed. - -Theorem c_semantic_preservation: - forall p tp, - match_prog p tp -> - backward_simulation (Csem.semantics p) (Asm.semantics tp). -Proof. - intros. - apply compose_backward_simulation with (atomic (Cstrategy.semantics p)). - eapply sd_traces; eapply Asm.semantics_determinate. - apply factor_backward_simulation. - apply Cstrategy.strategy_simulation. - apply Csem.semantics_single_events. - eapply ssr_well_behaved; eapply Cstrategy.semantics_strongly_receptive. - exact (proj2 (cstrategy_semantic_preservation _ _ H)). -Qed. - -(** * Correctness of the CompCert compiler *) - -(** Combining the results above, we obtain semantic preservation for two - usage scenarios of CompCert: compilation of a single monolithic program, - and separate compilation of multiple source files followed by linking. - - In the monolithic case, we have a whole C program [p] that is - compiled in one run of CompCert to a whole Asm program [tp]. - Then, [tp] preserves the semantics of [p], in the sense that there - exists a backward simulation of the dynamic semantics of [p] - by the dynamic semantics of [tp]. *) - -Theorem transf_c_program_correct: - forall p tp, - transf_c_program p = OK tp -> - backward_simulation (Csem.semantics p) (Asm.semantics tp). -Proof. - intros. apply c_semantic_preservation. apply transf_c_program_match; auto. -Qed. - -(** Here is the separate compilation case. Consider a nonempty list [c_units] - of C source files (compilation units), [C1 ,,, Cn]. Assume that every - C compilation unit [Ci] is successfully compiled by CompCert, obtaining - an Asm compilation unit [Ai]. Let [asm_unit] be the nonempty list - [A1 ... An]. Further assume that the C units [C1 ... Cn] can be linked - together to produce a whole C program [c_program]. Then, the generated - Asm units can be linked together, producing a whole Asm program - [asm_program]. Moreover, [asm_program] preserves the semantics of - [c_program], in the sense that there exists a backward simulation of - the dynamic semantics of [asm_program] by the dynamic semantics of [c_program]. -*) - -Theorem separate_transf_c_program_correct: - forall c_units asm_units c_program, - nlist_forall2 (fun cu tcu => transf_c_program cu = OK tcu) c_units asm_units -> - link_list c_units = Some c_program -> - exists asm_program, - link_list asm_units = Some asm_program - /\ backward_simulation (Csem.semantics c_program) (Asm.semantics asm_program). -Proof. - intros. - assert (nlist_forall2 match_prog c_units asm_units). - { eapply nlist_forall2_imply. eauto. simpl; intros. apply transf_c_program_match; auto. } - assert (exists asm_program, link_list asm_units = Some asm_program /\ match_prog c_program asm_program). - { eapply link_list_compose_passes; eauto. } - destruct H2 as (asm_program & P & Q). - exists asm_program; split; auto. apply c_semantic_preservation; auto. -Qed. diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand new file mode 100644 index 00000000..4c7c963a --- /dev/null +++ b/driver/Compiler.vexpand @@ -0,0 +1,533 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** The whole compiler and its proof of semantic preservation *) + +(** Libraries. *) +Require Import String. +Require Import Coqlib Errors. +Require Import AST Linking Smallstep. +(** Languages (syntax and semantics). *) +Require Ctypes Csyntax Csem Cstrategy Cexec. +Require Clight. +Require Csharpminor. +Require Cminor. +Require CminorSel. +Require RTL. +Require LTL. +Require Linear. +Require Mach. +Require Asm. +(** Translation passes. *) +Require Initializers. +Require SimplExpr. +Require SimplLocals. +Require Cshmgen. +Require Cminorgen. +Require Selection. +Require RTLgen. +Require Tailcall. +Require Inlining. +Require Profiling. +Require ProfilingExploit. +Require FirstNop. +Require Renumber. +Require Duplicate. +Require Constprop. +Require LICM. +Require CSE. +Require ForwardMoves. +Require CSE2. +Require CSE3. +Require Deadcode. +Require Unusedglob. +Require Allnontrap. +Require Allocation. +Require Tunneling. +Require Linearize. +Require CleanupLabels. +Require Debugvar. +Require Stacking. +Require Asmgen. +(** Proofs of semantic preservation. *) +Require SimplExprproof. +Require SimplLocalsproof. +Require Cshmgenproof. +Require Cminorgenproof. +Require Selectionproof. +Require RTLgenproof. +Require Tailcallproof. +Require Inliningproof. +Require Profilingproof. +Require ProfilingExploitproof. +Require FirstNopproof. +Require Renumberproof. +Require Duplicateproof. +Require Constpropproof. +Require LICMproof. +Require CSEproof. +Require ForwardMovesproof. +Require CSE2proof. +Require CSE3proof. +Require Deadcodeproof. +Require Unusedglobproof. +Require Allnontrapproof. +Require Allocproof. +Require Tunnelingproof. +Require Linearizeproof. +Require CleanupLabelsproof. +Require Debugvarproof. +Require Stackingproof. +Require Import Asmgenproof. +(** Command-line flags. *) +Require Import Compopts. + +(** Pretty-printers (defined in Caml). *) +Parameter print_Clight: Clight.program -> unit. +Parameter print_Cminor: Cminor.program -> unit. +Parameter print_RTL: Z -> RTL.program -> unit. +Parameter print_LTL: LTL.program -> unit. +Parameter print_Mach: Mach.program -> unit. + +Local Open Scope string_scope. + +(** * Composing the translation passes *) + +(** We first define useful monadic composition operators, + along with funny (but convenient) notations. *) + +Definition apply_total (A B: Type) (x: res A) (f: A -> B) : res B := + match x with Error msg => Error msg | OK x1 => OK (f x1) end. + +Definition apply_partial (A B: Type) + (x: res A) (f: A -> res B) : res B := + match x with Error msg => Error msg | OK x1 => f x1 end. + +Notation "a @@@ b" := + (apply_partial _ _ a b) (at level 50, left associativity). +Notation "a @@ b" := + (apply_total _ _ a b) (at level 50, left associativity). + +Definition print {A: Type} (printer: A -> unit) (prog: A) : A := + let unused := printer prog in prog. + +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f. + +Definition total_if {A: Type} + (flag: unit -> bool) (f: A -> A) (prog: A) : A := + if flag tt then f prog else prog. + +Definition partial_if {A: Type} + (flag: unit -> bool) (f: A -> res A) (prog: A) : res A := + if flag tt then f prog else OK prog. + +(** We define three translation functions for whole programs: one + starting with a C program, one with a Cminor program, one with an + RTL program. The three translations produce Asm programs ready for + pretty-printing and assembling. *) + +Definition transf_rtl_program (f: RTL.program) : res Asm.program := + OK f + @@ print (print_RTL 0) +EXPAND_TRANSF_PROGRAM + @@@ time "Register allocation" Allocation.transf_program + @@ print print_LTL + @@ time "Branch tunneling" Tunneling.tunnel_program + @@@ time "CFG linearization" Linearize.transf_program + @@ time "Label cleanup" CleanupLabels.transf_program + @@@ partial_if Compopts.debug (time "Debugging info for local variables" Debugvar.transf_program) + @@@ time "Mach generation" Stacking.transf_program + @@ print print_Mach + @@@ time "Total Mach->Asm generation" Asmgen.transf_program. + +Definition transf_cminor_program (p: Cminor.program) : res Asm.program := + OK p + @@ print print_Cminor + @@@ time "Instruction selection" Selection.sel_program + @@@ time "RTL generation" RTLgen.transl_program + @@@ transf_rtl_program. + +Definition transf_clight_program (p: Clight.program) : res Asm.program := + OK p + @@ print print_Clight + @@@ time "Simplification of locals" SimplLocals.transf_program + @@@ time "C#minor generation" Cshmgen.transl_program + @@@ time "Cminor generation" Cminorgen.transl_program + @@@ transf_cminor_program. + +Definition transf_c_program (p: Csyntax.program) : res Asm.program := + OK p + @@@ time "Clight generation" SimplExpr.transl_program + @@@ transf_clight_program. + +(** Force [Initializers] and [Cexec] to be extracted as well. *) + +Definition transl_init := Initializers.transl_init. +Definition cexec_do_step := Cexec.do_step. + +(** The following lemmas help reason over compositions of passes. *) + +Lemma print_identity: + forall (A: Type) (printer: A -> unit) (prog: A), + print printer prog = prog. +Proof. + intros; unfold print. destruct (printer prog); auto. +Qed. + +Lemma compose_print_identity: + forall (A: Type) (x: res A) (f: A -> unit), + x @@ print f = x. +Proof. + intros. destruct x; simpl. rewrite print_identity. auto. auto. +Qed. + +(** * Relational specification of compilation *) + +Definition match_if {A: Type} (flag: unit -> bool) (R: A -> A -> Prop): A -> A -> Prop := + if flag tt then R else eq. + +Lemma total_if_match: + forall (A: Type) (flag: unit -> bool) (f: A -> A) (rel: A -> A -> Prop) (prog: A), + (forall p, rel p (f p)) -> + match_if flag rel prog (total_if flag f prog). +Proof. + intros. unfold match_if, total_if. destruct (flag tt); auto. +Qed. + +Lemma partial_if_match: + forall (A: Type) (flag: unit -> bool) (f: A -> res A) (rel: A -> A -> Prop) (prog tprog: A), + (forall p tp, f p = OK tp -> rel p tp) -> + partial_if flag f prog = OK tprog -> + match_if flag rel prog tprog. +Proof. + intros. unfold match_if, partial_if in *. destruct (flag tt). auto. congruence. +Qed. + +Instance TransfIfLink {A: Type} {LA: Linker A} + (flag: unit -> bool) (transf: A -> A -> Prop) (TL: TransfLink transf) + : TransfLink (match_if flag transf). +Proof. + unfold match_if. destruct (flag tt). +- auto. +- red; intros. subst tp1 tp2. exists p; auto. +Qed. + +(** This is the list of compilation passes of CompCert in relational style. + Each pass is characterized by a [match_prog] relation between its + input code and its output code. The [mkpass] and [:::] combinators, + defined in module [Linking], ensure that the passes are composable + (the output language of a pass is the input language of the next pass) + and that they commute with linking (property [TransfLink], inferred + by the type class mechanism of Coq). *) + +Local Open Scope linking_scope. + +Definition CompCert's_passes := + mkpass SimplExprproof.match_prog + ::: mkpass SimplLocalsproof.match_prog + ::: mkpass Cshmgenproof.match_prog + ::: mkpass Cminorgenproof.match_prog + ::: mkpass Selectionproof.match_prog + ::: mkpass RTLgenproof.match_prog + ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) + ::: mkpass Inliningproof.match_prog + ::: mkpass (match_if Compopts.profile_arcs Profilingproof.match_prog) + ::: mkpass (match_if Compopts.branch_probabilities ProfilingExploitproof.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants FirstNopproof.match_prog) + ::: mkpass Renumberproof.match_prog + ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) + ::: mkpass Renumberproof.match_prog + ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) + ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE3 CSE3proof.match_prog) + ::: mkpass (match_if Compopts.optim_forward_moves ForwardMovesproof.match_prog) + ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) + ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog) + ::: mkpass Unusedglobproof.match_prog + ::: mkpass Allocproof.match_prog + ::: mkpass Tunnelingproof.match_prog + ::: mkpass Linearizeproof.match_prog + ::: mkpass CleanupLabelsproof.match_prog + ::: mkpass (match_if Compopts.debug Debugvarproof.match_prog) + ::: mkpass Stackingproof.match_prog + ::: mkpass Asmgenproof.match_prog + ::: pass_nil _. + +(** Composing the [match_prog] relations above, we obtain the relation + between CompCert C sources and Asm code that characterize CompCert's + compilation. *) + +Definition match_prog: Csyntax.program -> Asm.program -> Prop := + pass_match (compose_passes CompCert's_passes). + +(** The [transf_c_program] function, when successful, produces + assembly code that is in the [match_prog] relation with the source C program. *) + +Theorem transf_c_program_match: + forall p tp, + transf_c_program p = OK tp -> + match_prog p tp. +Proof. + intros p tp T. + unfold transf_c_program, time in T. simpl in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. + destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + set (p8bis := total_if profile_arcs Profiling.transf_program p8) in *. + set (p8ter := total_if branch_probabilities ProfilingExploit.transf_program p8bis) in *. + set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8ter) in *. + set (p9bis := Renumber.transf_program p9) in *. + destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. + set (p11 := Renumber.transf_program p10) in *. + set (p12 := total_if optim_constprop Constprop.transf_program p11) in *. + destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. + set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. + destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. + set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. + destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. + set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. + destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. + set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. + destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. + destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. + set (p17 := Tunneling.tunnel_program p16) in *. + destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. + set (p19 := CleanupLabels.transf_program p18) in *. + destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. + destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. + unfold match_prog; simpl. + exists p1; split. apply SimplExprproof.transf_program_match; auto. + exists p2; split. apply SimplLocalsproof.match_transf_program; auto. + exists p3; split. apply Cshmgenproof.transf_program_match; auto. + exists p4; split. apply Cminorgenproof.transf_program_match; auto. + exists p5; split. apply Selectionproof.transf_program_match; auto. + exists p6; split. apply RTLgenproof.transf_program_match; auto. + exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. + exists p8; split. apply Inliningproof.transf_program_match; auto. + exists p8bis; split. apply total_if_match. apply Profilingproof.transf_program_match; auto. + exists p8ter; split. apply total_if_match. apply ProfilingExploitproof.transf_program_match; auto. + exists p9; split. apply total_if_match. apply FirstNopproof.transf_program_match. + exists p9bis; split. apply Renumberproof.transf_program_match. + exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. + exists p11; split. apply Renumberproof.transf_program_match. + exists p12; split. apply total_if_match. apply Constpropproof.transf_program_match. + exists p12bis; split. eapply partial_if_match; eauto. apply LICMproof.transf_program_match. + exists p12ter; split. apply total_if_match; eauto. apply Renumberproof.transf_program_match. + exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. + exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. + exists p13ter; split. eapply partial_if_match; eauto. apply CSE3proof.transf_program_match. + exists p13quater; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. + exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. + exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match. + exists p15; split. apply Unusedglobproof.transf_program_match; auto. + exists p16; split. apply Allocproof.transf_program_match; auto. + exists p17; split. apply Tunnelingproof.transf_program_match. + exists p18; split. apply Linearizeproof.transf_program_match; auto. + exists p19; split. apply CleanupLabelsproof.transf_program_match; auto. + exists p20; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. + exists p21; split. apply Stackingproof.transf_program_match; auto. + exists tp; split. apply Asmgenproof.transf_program_match; auto. + reflexivity. +Qed. + +(** * Semantic preservation *) + +(** We now prove that the whole CompCert compiler (as characterized by the + [match_prog] relation) preserves semantics by constructing + the following simulations: +- Forward simulations from [Cstrategy] to [Asm] + (composition of the forward simulations for each pass). +- Backward simulations for the same languages + (derived from the forward simulation, using receptiveness of the source + language and determinacy of [Asm]). +- Backward simulation from [Csem] to [Asm] + (composition of two backward simulations). +*) + +Remark forward_simulation_identity: + forall sem, forward_simulation sem sem. +Proof. + intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. +- auto. +- exists s1; auto. +- subst s2; auto. +- subst s2. exists s1'; auto. +Qed. + +Lemma match_if_simulation: + forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (transf: A -> A -> Prop) (prog tprog: A), + match_if flag transf prog tprog -> + (forall p tp, transf p tp -> forward_simulation (sem p) (sem tp)) -> + forward_simulation (sem prog) (sem tprog). +Proof. + intros. unfold match_if in *. destruct (flag tt). eauto. subst. apply forward_simulation_identity. +Qed. + +Theorem cstrategy_semantic_preservation: + forall p tp, + match_prog p tp -> + forward_simulation (Cstrategy.semantics p) (Asm.semantics tp) + /\ backward_simulation (atomic (Cstrategy.semantics p)) (Asm.semantics tp). +Proof. + intros p tp M. unfold match_prog, pass_match in M; simpl in M. +Ltac DestructM := + match goal with + [ H: exists p, _ /\ _ |- _ ] => + let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in + destruct H as (p & M & MM); clear H + end. + repeat DestructM. subst tp. + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p31)). + { + eapply compose_forward_simulations. + eapply SimplExprproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply SimplLocalsproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cshmgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cminorgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Selectionproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply RTLgenproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. + eapply compose_forward_simulations. + eapply Inliningproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Profilingproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact ProfilingExploitproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact FirstNopproof.transf_program_correct. + eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. + eapply compose_forward_simulations. + eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact LICMproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact CSE2proof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact CSE3proof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact ForwardMovesproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Allnontrapproof.transf_program_correct. + eapply compose_forward_simulations. + eapply Unusedglobproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Allocproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Tunnelingproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Linearizeproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply CleanupLabelsproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Debugvarproof.transf_program_correct. + eapply compose_forward_simulations. + eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof0.return_address_offset). + exact Asmgenproof.return_address_exists. + eassumption. + eapply Asmgenproof.transf_program_correct; eassumption. + } + split. auto. + apply forward_to_backward_simulation. + apply factor_forward_simulation. auto. eapply sd_traces. eapply Asm.semantics_determinate. + apply atomic_receptive. apply Cstrategy.semantics_strongly_receptive. + apply Asm.semantics_determinate. +Qed. + +Theorem c_semantic_preservation: + forall p tp, + match_prog p tp -> + backward_simulation (Csem.semantics p) (Asm.semantics tp). +Proof. + intros. + apply compose_backward_simulation with (atomic (Cstrategy.semantics p)). + eapply sd_traces; eapply Asm.semantics_determinate. + apply factor_backward_simulation. + apply Cstrategy.strategy_simulation. + apply Csem.semantics_single_events. + eapply ssr_well_behaved; eapply Cstrategy.semantics_strongly_receptive. + exact (proj2 (cstrategy_semantic_preservation _ _ H)). +Qed. + +(** * Correctness of the CompCert compiler *) + +(** Combining the results above, we obtain semantic preservation for two + usage scenarios of CompCert: compilation of a single monolithic program, + and separate compilation of multiple source files followed by linking. + + In the monolithic case, we have a whole C program [p] that is + compiled in one run of CompCert to a whole Asm program [tp]. + Then, [tp] preserves the semantics of [p], in the sense that there + exists a backward simulation of the dynamic semantics of [p] + by the dynamic semantics of [tp]. *) + +Theorem transf_c_program_correct: + forall p tp, + transf_c_program p = OK tp -> + backward_simulation (Csem.semantics p) (Asm.semantics tp). +Proof. + intros. apply c_semantic_preservation. apply transf_c_program_match; auto. +Qed. + +(** Here is the separate compilation case. Consider a nonempty list [c_units] + of C source files (compilation units), [C1 ,,, Cn]. Assume that every + C compilation unit [Ci] is successfully compiled by CompCert, obtaining + an Asm compilation unit [Ai]. Let [asm_unit] be the nonempty list + [A1 ... An]. Further assume that the C units [C1 ... Cn] can be linked + together to produce a whole C program [c_program]. Then, the generated + Asm units can be linked together, producing a whole Asm program + [asm_program]. Moreover, [asm_program] preserves the semantics of + [c_program], in the sense that there exists a backward simulation of + the dynamic semantics of [asm_program] by the dynamic semantics of [c_program]. +*) + +Theorem separate_transf_c_program_correct: + forall c_units asm_units c_program, + nlist_forall2 (fun cu tcu => transf_c_program cu = OK tcu) c_units asm_units -> + link_list c_units = Some c_program -> + exists asm_program, + link_list asm_units = Some asm_program + /\ backward_simulation (Csem.semantics c_program) (Asm.semantics asm_program). +Proof. + intros. + assert (nlist_forall2 match_prog c_units asm_units). + { eapply nlist_forall2_imply. eauto. simpl; intros. apply transf_c_program_match; auto. } + assert (exists asm_program, link_list asm_units = Some asm_program /\ match_prog c_program asm_program). + { eapply link_list_compose_passes; eauto. } + destruct H2 as (asm_program & P & Q). + exists asm_program; split; auto. apply c_semantic_preservation; auto. +Qed. diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml new file mode 100644 index 00000000..63808c1f --- /dev/null +++ b/tools/compiler_expand.ml @@ -0,0 +1,62 @@ +type is_partial = TOTAL | PARTIAL;; +type when_triggered = Always | Option of string;; + +let passes = +[| +TOTAL, (Option "optim_tailcalls"), (Some "Tail calls"), "Tailcall"; +PARTIAL, Always, (Some "Inlining"), "Inlining"; +TOTAL, (Option "profile_arcs"), (Some "Profiling insertion"), "Profiling"; +TOTAL, (Option "branch_probabilities"), (Some "Profiling use"), "ProfilingExploit"; +TOTAL, (Option "optim_move_loop_invariants"), (Some "Inserting initial nop"), "FirstNop"; +TOTAL, Always, (Some "Renumbering"), "Renumber"; +PARTIAL, (Option "optim_duplicate"), (Some "Tail-duplicating"), "Duplicate"; +TOTAL, Always, (Some "Renumbering pre constprop"), "Renumber"; +TOTAL, (Option "optim_constprop"), (Some "Constant propagation"), "Constprop"; +PARTIAL, (Option "optim_move_loop_invariants"), (Some "LICM"), "LICM"; +TOTAL, (Option "optim_move_loop_invariants"), (Some "Renumbering pre CSE"), "Renumber"; +PARTIAL, (Option "optim_CSE"), (Some "CSE"), "CSE"; +TOTAL, (Option "optim_CSE2"), (Some "CSE2"), "CSE2"; +PARTIAL, (Option "optim_CSE3"), (Some "CSE3"), "CSE3"; +TOTAL, (Option "optim_forward_moves"), (Some "Forwarding moves"), "ForwardMoves"; +PARTIAL, (Option "optim_redundancy"), (Some "Redundancy elimination"), "Deadcode"; +TOTAL, (Option "all_loads_nontrap"), None, "Allnontrap"; +PARTIAL, Always, (Some "Unused globals"), "Unusedglob" +|];; + +let totality = function TOTAL -> "total" | PARTIAL -> "partial";; + +let print_transf oc = + Array.iteri + (fun i (partial, trigger, time_label, pass_name) -> + output_string oc (match partial with + | TOTAL -> " @@ " + | PARTIAL -> " @@@ "); + (match trigger with + | Always -> () + | Option s -> + Printf.fprintf oc "%s_if Compopts.%s " (totality partial) s); + output_char oc '('; + (match time_label with + | None -> () + | Some s -> + Printf.fprintf oc "time \"%s\" " s); + Printf.fprintf oc "%s.transf_program)\n" pass_name; + Printf.fprintf oc " @@ print (print_RTL %d)\n" (succ i) + ) passes;; + +if (Array.length Sys.argv)<>3 +then exit 1;; + +let filename_in = Sys.argv.(1) and filename_out = Sys.argv.(2) in + let ic = open_in filename_in and oc = open_out filename_out in + try + while true + do + let line = input_line ic in + if line = "EXPAND_TRANSF_PROGRAM" + then print_transf oc + else (output_string oc line; + output_char oc '\n') + done + with End_of_file -> + (close_in ic; close_out oc);; -- cgit From 1bd4d678fb719a6a52ade232eb2b36a6e621677a Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 Apr 2020 22:24:31 +0200 Subject: Require autogen --- driver/Compiler.vexpand | 38 ++++---------------------------------- tools/compiler_expand.ml | 30 ++++++++++++++++++++++-------- 2 files changed, 26 insertions(+), 42 deletions(-) diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index 4c7c963a..d0ba33d3 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -35,22 +35,7 @@ Require Cshmgen. Require Cminorgen. Require Selection. Require RTLgen. -Require Tailcall. -Require Inlining. -Require Profiling. -Require ProfilingExploit. -Require FirstNop. -Require Renumber. -Require Duplicate. -Require Constprop. -Require LICM. -Require CSE. -Require ForwardMoves. -Require CSE2. -Require CSE3. -Require Deadcode. -Require Unusedglob. -Require Allnontrap. +EXPAND_RTL_REQUIRE Require Allocation. Require Tunneling. Require Linearize. @@ -65,22 +50,7 @@ Require Cshmgenproof. Require Cminorgenproof. Require Selectionproof. Require RTLgenproof. -Require Tailcallproof. -Require Inliningproof. -Require Profilingproof. -Require ProfilingExploitproof. -Require FirstNopproof. -Require Renumberproof. -Require Duplicateproof. -Require Constpropproof. -Require LICMproof. -Require CSEproof. -Require ForwardMovesproof. -Require CSE2proof. -Require CSE3proof. -Require Deadcodeproof. -Require Unusedglobproof. -Require Allnontrapproof. +EXPAND_RTL_REQUIRE_PROOF Require Allocproof. Require Tunnelingproof. Require Linearizeproof. @@ -138,7 +108,7 @@ Definition partial_if {A: Type} Definition transf_rtl_program (f: RTL.program) : res Asm.program := OK f @@ print (print_RTL 0) -EXPAND_TRANSF_PROGRAM +EXPAND_RTL_TRANSF_PROGRAM @@@ time "Register allocation" Allocation.transf_program @@ print print_LTL @@ time "Branch tunneling" Tunneling.tunnel_program @@ -308,7 +278,7 @@ Proof. set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. + destruct (Unusedglob.transf_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. set (p17 := Tunneling.tunnel_program p16) in *. destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 63808c1f..7ca3c755 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -1,7 +1,7 @@ type is_partial = TOTAL | PARTIAL;; type when_triggered = Always | Option of string;; -let passes = +let rtl_passes = [| TOTAL, (Option "optim_tailcalls"), (Some "Tail calls"), "Tailcall"; PARTIAL, Always, (Some "Inlining"), "Inlining"; @@ -25,7 +25,17 @@ PARTIAL, Always, (Some "Unused globals"), "Unusedglob" let totality = function TOTAL -> "total" | PARTIAL -> "partial";; -let print_transf oc = +let print_rtl_require oc = + Array.iter (fun (partial, trigger, time_label, pass_name) -> + Printf.fprintf oc "Require %s.\n" pass_name) + rtl_passes;; + +let print_rtl_require_proof oc = + Array.iter (fun (partial, trigger, time_label, pass_name) -> + Printf.fprintf oc "Require %sproof.\n" pass_name) + rtl_passes;; + +let print_rtl_transf oc = Array.iteri (fun i (partial, trigger, time_label, pass_name) -> output_string oc (match partial with @@ -42,7 +52,7 @@ let print_transf oc = Printf.fprintf oc "time \"%s\" " s); Printf.fprintf oc "%s.transf_program)\n" pass_name; Printf.fprintf oc " @@ print (print_RTL %d)\n" (succ i) - ) passes;; + ) rtl_passes;; if (Array.length Sys.argv)<>3 then exit 1;; @@ -52,11 +62,15 @@ let filename_in = Sys.argv.(1) and filename_out = Sys.argv.(2) in try while true do - let line = input_line ic in - if line = "EXPAND_TRANSF_PROGRAM" - then print_transf oc - else (output_string oc line; - output_char oc '\n') + match input_line ic with + | "EXPAND_RTL_TRANSF_PROGRAM" -> + print_rtl_transf oc + | "EXPAND_RTL_REQUIRE" -> + print_rtl_require oc + | "EXPAND_RTL_REQUIRE_PROOF" -> + print_rtl_require_proof oc + | line -> (output_string oc line; + output_char oc '\n') done with End_of_file -> (close_in ic; close_out oc);; -- cgit From 25547c7d1f6a0fb75ff1d8e7287d9305e0dbf293 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 21 Apr 2020 22:42:32 +0200 Subject: generate mkpass --- driver/Compiler.vexpand | 19 +------------------ tools/compiler_expand.ml | 14 +++++++++++++- 2 files changed, 14 insertions(+), 19 deletions(-) diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index d0ba33d3..c044d9ef 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -208,24 +208,7 @@ Definition CompCert's_passes := ::: mkpass Cminorgenproof.match_prog ::: mkpass Selectionproof.match_prog ::: mkpass RTLgenproof.match_prog - ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) - ::: mkpass Inliningproof.match_prog - ::: mkpass (match_if Compopts.profile_arcs Profilingproof.match_prog) - ::: mkpass (match_if Compopts.branch_probabilities ProfilingExploitproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants FirstNopproof.match_prog) - ::: mkpass Renumberproof.match_prog - ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog) - ::: mkpass Renumberproof.match_prog - ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants LICMproof.match_prog) - ::: mkpass (match_if Compopts.optim_move_loop_invariants Renumberproof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog) - ::: mkpass (match_if Compopts.optim_CSE3 CSE3proof.match_prog) - ::: mkpass (match_if Compopts.optim_forward_moves ForwardMovesproof.match_prog) - ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) - ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog) - ::: mkpass Unusedglobproof.match_prog +EXPAND_RTL_MKPASS ::: mkpass Allocproof.match_prog ::: mkpass Tunnelingproof.match_prog ::: mkpass Linearizeproof.match_prog diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 7ca3c755..1ef233e7 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -53,7 +53,17 @@ let print_rtl_transf oc = Printf.fprintf oc "%s.transf_program)\n" pass_name; Printf.fprintf oc " @@ print (print_RTL %d)\n" (succ i) ) rtl_passes;; - + +let print_rtl_mkpass oc = + Array.iter (fun (partial, trigger, time_label, pass_name) -> + output_string oc " ::: mkpass ("; + (match trigger with + | Always -> () + | Option s -> + Printf.fprintf oc "match_if Compopts.%s " s); + Printf.fprintf oc "%sproof.match_prog)\n" pass_name) + rtl_passes;; + if (Array.length Sys.argv)<>3 then exit 1;; @@ -69,6 +79,8 @@ let filename_in = Sys.argv.(1) and filename_out = Sys.argv.(2) in print_rtl_require oc | "EXPAND_RTL_REQUIRE_PROOF" -> print_rtl_require_proof oc + | "EXPAND_RTL_MKPASS" -> + print_rtl_mkpass oc | line -> (output_string oc line; output_char oc '\n') done -- cgit From f5da5188171962d13b9f3eac04845dd19d0aa931 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 22 Apr 2020 08:08:21 +0200 Subject: automated writing Compiler.v --- Makefile | 2 +- backend/Allocationproof.v | 2619 +++++++++++++++++++++++++++++++++++++++++++++ backend/Allocproof.v | 2619 --------------------------------------------- backend/Tunneling.v | 2 +- backend/Tunnelingproof.v | 2 +- driver/Compiler.vexpand | 119 +- tools/compiler_expand.ml | 87 +- 7 files changed, 2709 insertions(+), 2741 deletions(-) create mode 100644 backend/Allocationproof.v delete mode 100644 backend/Allocproof.v diff --git a/Makefile b/Makefile index 2f9ab029..ba8add27 100644 --- a/Makefile +++ b/Makefile @@ -100,7 +100,7 @@ BACKEND=\ ForwardMoves.v ForwardMovesproof.v \ FirstNop.v FirstNopproof.v \ Allnontrap.v Allnontrapproof.v \ - Allocation.v Allocproof.v \ + Allocation.v Allocationproof.v \ Tunneling.v Tunnelingproof.v \ Linear.v Lineartyping.v \ Linearize.v Linearizeproof.v \ diff --git a/backend/Allocationproof.v b/backend/Allocationproof.v new file mode 100644 index 00000000..3c7df58a --- /dev/null +++ b/backend/Allocationproof.v @@ -0,0 +1,2619 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for the [Allocation] pass (validated translation from + RTL to LTL). *) + +Require Import FunInd. +Require Import FSets. +Require Import Coqlib Ordered Maps Errors Integers Floats. +Require Import AST Linking Lattice Kildall. +Require Import Values Memory Globalenvs Events Smallstep. +Require Archi. +Require Import Op Registers RTL Locations Conventions RTLtyping LTL. +Require Import Allocation. + +Definition match_prog (p: RTL.program) (tp: LTL.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +(** * Soundness of structural checks *) + +Definition expand_move (m: move) : instruction := + match m with + | MV (R src) (R dst) => Lop Omove (src::nil) dst + | MV (S sl ofs ty) (R dst) => Lgetstack sl ofs ty dst + | MV (R src) (S sl ofs ty) => Lsetstack src sl ofs ty + | MV (S _ _ _) (S _ _ _) => Lreturn (**r should never happen *) + | MVmakelong src1 src2 dst => Lop Omakelong (src1::src2::nil) dst + | MVlowlong src dst => Lop Olowlong (src::nil) dst + | MVhighlong src dst => Lop Ohighlong (src::nil) dst + end. + +Definition expand_moves (mv: moves) (k: bblock) : bblock := + List.map expand_move mv ++ k. + +Definition wf_move (m: move) : Prop := + match m with + | MV (S _ _ _) (S _ _ _) => False + | _ => True + end. + +Definition wf_moves (mv: moves) : Prop := + List.Forall wf_move mv. + +Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Prop := + | ebs_nop: forall mv s k, + wf_moves mv -> + expand_block_shape (BSnop mv s) + (Inop s) + (expand_moves mv (Lbranch s :: k)) + | ebs_move: forall src dst mv s k, + wf_moves mv -> + expand_block_shape (BSmove src dst mv s) + (Iop Omove (src :: nil) dst s) + (expand_moves mv (Lbranch s :: k)) + | ebs_makelong: forall src1 src2 dst mv s k, + wf_moves mv -> + Archi.splitlong = true -> + expand_block_shape (BSmakelong src1 src2 dst mv s) + (Iop Omakelong (src1 :: src2 :: nil) dst s) + (expand_moves mv (Lbranch s :: k)) + | ebs_lowlong: forall src dst mv s k, + wf_moves mv -> + Archi.splitlong = true -> + expand_block_shape (BSlowlong src dst mv s) + (Iop Olowlong (src :: nil) dst s) + (expand_moves mv (Lbranch s :: k)) + | ebs_highlong: forall src dst mv s k, + wf_moves mv -> + Archi.splitlong = true -> + expand_block_shape (BShighlong src dst mv s) + (Iop Ohighlong (src :: nil) dst s) + (expand_moves mv (Lbranch s :: k)) + | ebs_op: forall op args res mv1 args' res' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + expand_block_shape (BSop op args res mv1 args' res' mv2 s) + (Iop op args res s) + (expand_moves mv1 + (Lop op args' res' :: expand_moves mv2 (Lbranch s :: k))) + | ebs_op_dead: forall op args res mv s k, + wf_moves mv -> + expand_block_shape (BSopdead op args res mv s) + (Iop op args res s) + (expand_moves mv (Lbranch s :: k)) + | ebs_load: forall trap chunk addr args dst mv1 args' dst' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + expand_block_shape (BSload trap chunk addr args dst mv1 args' dst' mv2 s) + (Iload trap chunk addr args dst s) + (expand_moves mv1 + (Lload trap chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k))) + | ebs_load2: forall addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s k, + wf_moves mv1 -> wf_moves mv2 -> wf_moves mv3 -> + Archi.splitlong = true -> + offset_addressing addr 4 = Some addr2 -> + expand_block_shape (BSload2 addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s) + (Iload TRAP Mint64 addr args dst s) + (expand_moves mv1 + (Lload TRAP Mint32 addr args1' dst1' :: + expand_moves mv2 + (Lload TRAP Mint32 addr2 args2' dst2' :: + expand_moves mv3 (Lbranch s :: k)))) + | ebs_load2_1: forall addr args dst mv1 args' dst' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + Archi.splitlong = true -> + expand_block_shape (BSload2_1 addr args dst mv1 args' dst' mv2 s) + (Iload TRAP Mint64 addr args dst s) + (expand_moves mv1 + (Lload TRAP Mint32 addr args' dst' :: + expand_moves mv2 (Lbranch s :: k))) + | ebs_load2_2: forall addr addr2 args dst mv1 args' dst' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + Archi.splitlong = true -> + offset_addressing addr 4 = Some addr2 -> + expand_block_shape (BSload2_2 addr addr2 args dst mv1 args' dst' mv2 s) + (Iload TRAP Mint64 addr args dst s) + (expand_moves mv1 + (Lload TRAP Mint32 addr2 args' dst' :: + expand_moves mv2 (Lbranch s :: k))) + | ebs_load_dead: forall trap chunk addr args dst mv s k, + wf_moves mv -> + expand_block_shape (BSloaddead chunk addr args dst mv s) + (Iload trap chunk addr args dst s) + (expand_moves mv (Lbranch s :: k)) + | ebs_store: forall chunk addr args src mv1 args' src' s k, + wf_moves mv1 -> + expand_block_shape (BSstore chunk addr args src mv1 args' src' s) + (Istore chunk addr args src s) + (expand_moves mv1 + (Lstore chunk addr args' src' :: Lbranch s :: k)) + | ebs_store2: forall addr addr2 args src mv1 args1' src1' mv2 args2' src2' s k, + wf_moves mv1 -> wf_moves mv2 -> + Archi.splitlong = true -> + offset_addressing addr 4 = Some addr2 -> + expand_block_shape (BSstore2 addr addr2 args src mv1 args1' src1' mv2 args2' src2' s) + (Istore Mint64 addr args src s) + (expand_moves mv1 + (Lstore Mint32 addr args1' src1' :: + expand_moves mv2 + (Lstore Mint32 addr2 args2' src2' :: + Lbranch s :: k))) + | ebs_call: forall sg ros args res mv1 ros' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + expand_block_shape (BScall sg ros args res mv1 ros' mv2 s) + (Icall sg ros args res s) + (expand_moves mv1 + (Lcall sg ros' :: expand_moves mv2 (Lbranch s :: k))) + | ebs_tailcall: forall sg ros args mv ros' k, + wf_moves mv -> + expand_block_shape (BStailcall sg ros args mv ros') + (Itailcall sg ros args) + (expand_moves mv (Ltailcall sg ros' :: k)) + | ebs_builtin: forall ef args res mv1 args' res' mv2 s k, + wf_moves mv1 -> wf_moves mv2 -> + expand_block_shape (BSbuiltin ef args res mv1 args' res' mv2 s) + (Ibuiltin ef args res s) + (expand_moves mv1 + (Lbuiltin ef args' res' :: expand_moves mv2 (Lbranch s :: k))) + | ebs_cond: forall cond args mv args' s1 s2 k i i', + wf_moves mv -> + expand_block_shape (BScond cond args mv args' s1 s2) + (Icond cond args s1 s2 i) + (expand_moves mv (Lcond cond args' s1 s2 i' :: k)) + | ebs_jumptable: forall arg mv arg' tbl k, + wf_moves mv -> + expand_block_shape (BSjumptable arg mv arg' tbl) + (Ijumptable arg tbl) + (expand_moves mv (Ljumptable arg' tbl :: k)) + | ebs_return: forall optarg mv k, + wf_moves mv -> + expand_block_shape (BSreturn optarg mv) + (Ireturn optarg) + (expand_moves mv (Lreturn :: k)). + +Ltac MonadInv := + match goal with + | [ H: match ?x with Some _ => _ | None => None end = Some _ |- _ ] => + destruct x as [] eqn:? ; [MonadInv|discriminate] + | [ H: match ?x with left _ => _ | right _ => None end = Some _ |- _ ] => + destruct x; [MonadInv|discriminate] + | [ H: match negb (proj_sumbool ?x) with true => _ | false => None end = Some _ |- _ ] => + destruct x; [discriminate|simpl in H; MonadInv] + | [ H: match negb ?x with true => _ | false => None end = Some _ |- _ ] => + destruct x as [] eqn:? ; [discriminate|simpl in H; MonadInv] + | [ H: match ?x with true => _ | false => None end = Some _ |- _ ] => + destruct x as [] eqn:? ; [MonadInv|discriminate] + | [ H: match ?x with (_, _) => _ end = Some _ |- _ ] => + destruct x as [] eqn:? ; MonadInv + | [ H: Some _ = Some _ |- _ ] => + inv H; MonadInv + | [ H: None = Some _ |- _ ] => + discriminate + | _ => + idtac + end. + +Remark expand_moves_cons: + forall m accu b, + expand_moves (rev (m :: accu)) b = expand_moves (rev accu) (expand_move m :: b). +Proof. + unfold expand_moves; intros. simpl. rewrite map_app. rewrite app_ass. auto. +Qed. + +Lemma extract_moves_sound: + forall b mv b', + extract_moves nil b = (mv, b') -> + wf_moves mv /\ b = expand_moves mv b'. +Proof. + assert (BASE: + forall accu b, + wf_moves accu -> + wf_moves (List.rev accu) /\ expand_moves (List.rev accu) b = expand_moves (List.rev accu) b). + { intros; split; auto. unfold wf_moves in *; rewrite Forall_forall in *. + intros. apply H. rewrite <- in_rev in H0; auto. } + + assert (IND: forall b accu mv b', + extract_moves accu b = (mv, b') -> + wf_moves accu -> + wf_moves mv /\ expand_moves (List.rev accu) b = expand_moves mv b'). + { induction b; simpl; intros. + - inv H. auto. + - destruct a; try (inv H; apply BASE; auto; fail). + + destruct (is_move_operation op args) as [arg|] eqn:E. + exploit is_move_operation_correct; eauto. intros [A B]; subst. + (* reg-reg move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + inv H; apply BASE; auto. + + (* stack-reg move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + + (* reg-stack move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + } + intros. exploit IND; eauto. constructor. +Qed. + +Lemma extract_moves_ext_sound: + forall b mv b', + extract_moves_ext nil b = (mv, b') -> + wf_moves mv /\ b = expand_moves mv b'. +Proof. + assert (BASE: + forall accu b, + wf_moves accu -> + wf_moves (List.rev accu) /\ expand_moves (List.rev accu) b = expand_moves (List.rev accu) b). + { intros; split; auto. unfold wf_moves in *; rewrite Forall_forall in *. + intros. apply H. rewrite <- in_rev in H0; auto. } + + assert (IND: forall b accu mv b', + extract_moves_ext accu b = (mv, b') -> + wf_moves accu -> + wf_moves mv /\ expand_moves (List.rev accu) b = expand_moves mv b'). + { induction b; simpl; intros. + - inv H. auto. + - destruct a; try (inv H; apply BASE; auto; fail). + + destruct (classify_operation op args). + * (* reg-reg move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + * (* makelong *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + * (* lowlong *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + * (* highlong *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + * (* default *) + inv H; apply BASE; auto. + + (* stack-reg move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + + (* reg-stack move *) + exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. + } + intros. exploit IND; eauto. constructor. +Qed. + +Lemma check_succ_sound: + forall s b, check_succ s b = true -> exists k, b = Lbranch s :: k. +Proof. + intros. destruct b; simpl in H; try discriminate. + destruct i; try discriminate. + destruct (peq s s0); simpl in H; inv H. exists b; auto. +Qed. + +Ltac UseParsingLemmas := + match goal with + | [ H: extract_moves nil _ = (_, _) |- _ ] => + destruct (extract_moves_sound _ _ _ H); clear H; subst; UseParsingLemmas + | [ H: extract_moves_ext nil _ = (_, _) |- _ ] => + destruct (extract_moves_ext_sound _ _ _ H); clear H; subst; UseParsingLemmas + | [ H: check_succ _ _ = true |- _ ] => + try (discriminate H); + destruct (check_succ_sound _ _ H); clear H; subst; UseParsingLemmas + | _ => idtac + end. + +Lemma pair_instr_block_sound: + forall i b bsh, + pair_instr_block i b = Some bsh -> expand_block_shape bsh i b. +Proof. + assert (OP: forall op args res s b bsh, + pair_Iop_block op args res s b = Some bsh -> expand_block_shape bsh (Iop op args res s) b). + { + unfold pair_Iop_block; intros. MonadInv. destruct b0. + MonadInv; UseParsingLemmas. + destruct i; MonadInv; UseParsingLemmas. + eapply ebs_op; eauto. + inv H0. eapply ebs_op_dead; eauto. } + + intros; destruct i; simpl in H; MonadInv; UseParsingLemmas. +- (* nop *) + econstructor; eauto. +- (* op *) + destruct (classify_operation o l). ++ (* move *) + MonadInv; UseParsingLemmas. econstructor; eauto. ++ (* makelong *) + destruct Archi.splitlong eqn:SL; eauto. + MonadInv; UseParsingLemmas. econstructor; eauto. ++ (* lowlong *) + destruct Archi.splitlong eqn:SL; eauto. + MonadInv; UseParsingLemmas. econstructor; eauto. ++ (* highlong *) + destruct Archi.splitlong eqn:SL; eauto. + MonadInv; UseParsingLemmas. econstructor; eauto. ++ (* other ops *) + eauto. +- (* load *) + destruct b0 as [ | [] b0]; MonadInv; UseParsingLemmas. + destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. + destruct b as [ | [] b]; MonadInv; UseParsingLemmas. + InvBooleans. subst m. eapply ebs_load2; eauto. + InvBooleans. subst m. + destruct (eq_addressing a addr). + inv H; inv H2. eapply ebs_load2_1; eauto. + destruct (option_eq eq_addressing (offset_addressing a 4) (Some addr)). + inv H; inv H2. eapply ebs_load2_2; eauto. + discriminate. + eapply ebs_load; eauto. + inv H. eapply ebs_load_dead; eauto. +- (* store *) + destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. + destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. + destruct b as [ | [] b]; MonadInv; UseParsingLemmas. + InvBooleans. subst m. eapply ebs_store2; eauto. + eapply ebs_store; eauto. +- (* call *) + destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* tailcall *) + destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* builtin *) + destruct b1 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* cond *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* jumptable *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. +- (* return *) + destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. +Qed. + +Lemma matching_instr_block: + forall f1 f2 pc bsh i, + (pair_codes f1 f2)!pc = Some bsh -> + (RTL.fn_code f1)!pc = Some i -> + exists b, (LTL.fn_code f2)!pc = Some b /\ expand_block_shape bsh i b. +Proof. + intros. unfold pair_codes in H. rewrite PTree.gcombine in H; auto. rewrite H0 in H. + destruct (LTL.fn_code f2)!pc as [b|]. + exists b; split; auto. apply pair_instr_block_sound; auto. + discriminate. +Qed. + +(** * Properties of equations *) + +Module ESF := FSetFacts.Facts(EqSet). +Module ESP := FSetProperties.Properties(EqSet). +Module ESD := FSetDecide.Decide(EqSet). + +Definition sel_val (k: equation_kind) (v: val) : val := + match k with + | Full => v + | Low => Val.loword v + | High => Val.hiword v + end. + +(** A set of equations [e] is satisfied in a RTL pseudoreg state [rs] + and an LTL location state [ls] if, for every equation [r = l [k]] in [e], + [sel_val k (rs#r)] (the [k] fragment of [r]'s value in the RTL code) + is less defined than [ls l] (the value of [l] in the LTL code). *) + +Definition satisf (rs: regset) (ls: locset) (e: eqs) : Prop := + forall q, EqSet.In q e -> Val.lessdef (sel_val (ekind q) rs#(ereg q)) (ls (eloc q)). + +Lemma empty_eqs_satisf: + forall rs ls, satisf rs ls empty_eqs. +Proof. + unfold empty_eqs; intros; red; intros. ESD.fsetdec. +Qed. + +Lemma satisf_incr: + forall rs ls (e1 e2: eqs), + satisf rs ls e2 -> EqSet.Subset e1 e2 -> satisf rs ls e1. +Proof. + unfold satisf; intros. apply H. ESD.fsetdec. +Qed. + +Lemma satisf_undef_reg: + forall rs ls e r, + satisf rs ls e -> + satisf (rs#r <- Vundef) ls e. +Proof. + intros; red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r); auto. + destruct (ekind q); simpl; auto. +Qed. + +Lemma add_equation_lessdef: + forall rs ls q e, + satisf rs ls (add_equation q e) -> Val.lessdef (sel_val (ekind q) rs#(ereg q)) (ls (eloc q)). +Proof. + intros. apply H. unfold add_equation. simpl. apply EqSet.add_1. auto. +Qed. + +Lemma add_equation_satisf: + forall rs ls q e, + satisf rs ls (add_equation q e) -> satisf rs ls e. +Proof. + intros. eapply satisf_incr; eauto. unfold add_equation. simpl. ESD.fsetdec. +Qed. + +Lemma add_equations_satisf: + forall rs ls rl ml e e', + add_equations rl ml e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + induction rl; destruct ml; simpl; intros; MonadInv. + auto. + eapply add_equation_satisf; eauto. +Qed. + +Lemma add_equations_lessdef: + forall rs ls rl ml e e', + add_equations rl ml e = Some e' -> + satisf rs ls e' -> + Val.lessdef_list (rs##rl) (reglist ls ml). +Proof. + induction rl; destruct ml; simpl; intros; MonadInv. + constructor. + constructor; eauto. + apply add_equation_lessdef with (e := e) (q := Eq Full a (R m)). + eapply add_equations_satisf; eauto. +Qed. + +Lemma add_equations_args_satisf: + forall rs ls rl tyl ll e e', + add_equations_args rl tyl ll e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + intros until e'. functional induction (add_equations_args rl tyl ll e); intros. +- inv H; auto. +- eapply add_equation_satisf; eauto. +- discriminate. +- eapply add_equation_satisf. eapply add_equation_satisf. eauto. +- congruence. +Qed. + +Lemma val_longofwords_eq_1: + forall v, + Val.has_type v Tlong -> Archi.ptr64 = false -> + Val.longofwords (Val.hiword v) (Val.loword v) = v. +Proof. + intros. red in H. destruct v; try contradiction. +- reflexivity. +- simpl. rewrite Int64.ofwords_recompose. auto. +- congruence. +Qed. + +Lemma val_longofwords_eq_2: + forall v, + Val.has_type v Tlong -> Archi.splitlong = true -> + Val.longofwords (Val.hiword v) (Val.loword v) = v. +Proof. + intros. apply Archi.splitlong_ptr32 in H0. apply val_longofwords_eq_1; assumption. +Qed. + +Lemma add_equations_args_lessdef: + forall rs ls rl tyl ll e e', + add_equations_args rl tyl ll e = Some e' -> + satisf rs ls e' -> + Val.has_type_list (rs##rl) tyl -> + Val.lessdef_list (rs##rl) (map (fun p => Locmap.getpair p ls) ll). +Proof. + intros until e'. functional induction (add_equations_args rl tyl ll e); simpl; intros. +- inv H; auto. +- destruct H1. constructor; auto. + eapply add_equation_lessdef with (q := Eq Full r1 l1). eapply add_equations_args_satisf; eauto. +- discriminate. +- destruct H1. constructor; auto. + rewrite <- (val_longofwords_eq_1 (rs#r1)) by auto. apply Val.longofwords_lessdef. + eapply add_equation_lessdef with (q := Eq High r1 l1). + eapply add_equation_satisf. eapply add_equations_args_satisf; eauto. + eapply add_equation_lessdef with (q := Eq Low r1 l2). + eapply add_equations_args_satisf; eauto. +- discriminate. +Qed. + +Lemma add_equation_ros_satisf: + forall rs ls ros mos e e', + add_equation_ros ros mos e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + unfold add_equation_ros; intros. destruct ros; destruct mos; MonadInv. + eapply add_equation_satisf; eauto. + auto. +Qed. + +Lemma remove_equation_satisf: + forall rs ls q e, + satisf rs ls e -> satisf rs ls (remove_equation q e). +Proof. + intros. eapply satisf_incr; eauto. unfold remove_equation; simpl. ESD.fsetdec. +Qed. + +Lemma remove_equation_res_satisf: + forall rs ls r l e e', + remove_equations_res r l e = Some e' -> + satisf rs ls e -> satisf rs ls e'. +Proof. + intros. functional inversion H. + apply remove_equation_satisf; auto. + apply remove_equation_satisf. apply remove_equation_satisf; auto. +Qed. + +Remark select_reg_l_monotone: + forall r q1 q2, + OrderedEquation.eq q1 q2 \/ OrderedEquation.lt q1 q2 -> + select_reg_l r q1 = true -> select_reg_l r q2 = true. +Proof. + unfold select_reg_l; intros. destruct H. + red in H. congruence. + rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. + red in A. zify; omega. + rewrite <- A; auto. +Qed. + +Remark select_reg_h_monotone: + forall r q1 q2, + OrderedEquation.eq q1 q2 \/ OrderedEquation.lt q2 q1 -> + select_reg_h r q1 = true -> select_reg_h r q2 = true. +Proof. + unfold select_reg_h; intros. destruct H. + red in H. congruence. + rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. + red in A. zify; omega. + rewrite A; auto. +Qed. + +Remark select_reg_charact: + forall r q, select_reg_l r q = true /\ select_reg_h r q = true <-> ereg q = r. +Proof. + unfold select_reg_l, select_reg_h; intros; split. + rewrite ! Pos.leb_le. unfold reg; zify; omega. + intros. rewrite H. rewrite ! Pos.leb_refl; auto. +Qed. + +Lemma reg_unconstrained_sound: + forall r e q, + reg_unconstrained r e = true -> + EqSet.In q e -> + ereg q <> r. +Proof. + unfold reg_unconstrained; intros. red; intros. + apply select_reg_charact in H1. + assert (EqSet.mem_between (select_reg_l r) (select_reg_h r) e = true). + { + apply EqSet.mem_between_2 with q; auto. + exact (select_reg_l_monotone r). + exact (select_reg_h_monotone r). + tauto. + tauto. + } + rewrite H2 in H; discriminate. +Qed. + +Lemma reg_unconstrained_satisf: + forall r e rs ls v, + reg_unconstrained r e = true -> + satisf rs ls e -> + satisf (rs#r <- v) ls e. +Proof. + red; intros. rewrite PMap.gso. auto. eapply reg_unconstrained_sound; eauto. +Qed. + +Remark select_loc_l_monotone: + forall l q1 q2, + OrderedEquation'.eq q1 q2 \/ OrderedEquation'.lt q1 q2 -> + select_loc_l l q1 = true -> select_loc_l l q2 = true. +Proof. + unfold select_loc_l; intros. set (lb := OrderedLoc.diff_low_bound l) in *. + destruct H. + red in H. subst q2; auto. + assert (eloc q1 = eloc q2 \/ OrderedLoc.lt (eloc q1) (eloc q2)). + red in H. tauto. + destruct H1. rewrite <- H1; auto. + destruct (OrderedLoc.compare (eloc q2) lb); auto. + assert (OrderedLoc.lt (eloc q1) lb) by (eapply OrderedLoc.lt_trans; eauto). + destruct (OrderedLoc.compare (eloc q1) lb). + auto. + eelim OrderedLoc.lt_not_eq; eauto. + eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans. eexact l1. eexact H2. red; auto. +Qed. + +Remark select_loc_h_monotone: + forall l q1 q2, + OrderedEquation'.eq q1 q2 \/ OrderedEquation'.lt q2 q1 -> + select_loc_h l q1 = true -> select_loc_h l q2 = true. +Proof. + unfold select_loc_h; intros. set (lb := OrderedLoc.diff_high_bound l) in *. + destruct H. + red in H. subst q2; auto. + assert (eloc q2 = eloc q1 \/ OrderedLoc.lt (eloc q2) (eloc q1)). + red in H. tauto. + destruct H1. rewrite H1; auto. + destruct (OrderedLoc.compare (eloc q2) lb); auto. + assert (OrderedLoc.lt lb (eloc q1)) by (eapply OrderedLoc.lt_trans; eauto). + destruct (OrderedLoc.compare (eloc q1) lb). + eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans. eexact l1. eexact H2. red; auto. + eelim OrderedLoc.lt_not_eq. eexact H2. apply OrderedLoc.eq_sym; auto. + auto. +Qed. + +Remark select_loc_charact: + forall l q, + select_loc_l l q = false \/ select_loc_h l q = false <-> Loc.diff l (eloc q). +Proof. + unfold select_loc_l, select_loc_h; intros; split; intros. + apply OrderedLoc.outside_interval_diff. + destruct H. + left. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_low_bound l)); assumption || discriminate. + right. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_high_bound l)); assumption || discriminate. + exploit OrderedLoc.diff_outside_interval. eauto. + intros [A | A]. + left. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_low_bound l)). + auto. + eelim OrderedLoc.lt_not_eq; eauto. + eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans; eauto. red; auto. + right. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_high_bound l)). + eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans; eauto. red; auto. + eelim OrderedLoc.lt_not_eq; eauto. apply OrderedLoc.eq_sym; auto. + auto. +Qed. + +Lemma loc_unconstrained_sound: + forall l e q, + loc_unconstrained l e = true -> + EqSet.In q e -> + Loc.diff l (eloc q). +Proof. + unfold loc_unconstrained; intros. + destruct (select_loc_l l q) eqn:SL. + destruct (select_loc_h l q) eqn:SH. + assert (EqSet2.mem_between (select_loc_l l) (select_loc_h l) (eqs2 e) = true). + { + apply EqSet2.mem_between_2 with q; auto. + exact (select_loc_l_monotone l). + exact (select_loc_h_monotone l). + apply eqs_same. auto. + } + rewrite H1 in H; discriminate. + apply select_loc_charact; auto. + apply select_loc_charact; auto. +Qed. + +Lemma loc_unconstrained_satisf: + forall rs ls k r mr e v, + let l := R mr in + satisf rs ls (remove_equation (Eq k r l) e) -> + loc_unconstrained (R mr) (remove_equation (Eq k r l) e) = true -> + Val.lessdef (sel_val k rs#r) v -> + satisf rs (Locmap.set l v ls) e. +Proof. + intros; red; intros. + destruct (OrderedEquation.eq_dec q (Eq k r l)). + subst q; simpl. unfold l; rewrite Locmap.gss. auto. + assert (EqSet.In q (remove_equation (Eq k r l) e)). + simpl. ESD.fsetdec. + rewrite Locmap.gso. apply H; auto. eapply loc_unconstrained_sound; eauto. +Qed. + +Lemma reg_loc_unconstrained_sound: + forall r l e q, + reg_loc_unconstrained r l e = true -> + EqSet.In q e -> + ereg q <> r /\ Loc.diff l (eloc q). +Proof. + intros. destruct (andb_prop _ _ H). + split. eapply reg_unconstrained_sound; eauto. eapply loc_unconstrained_sound; eauto. +Qed. + +Lemma parallel_assignment_satisf: + forall k r mr e rs ls v v', + let l := R mr in + Val.lessdef (sel_val k v) v' -> + reg_loc_unconstrained r (R mr) (remove_equation (Eq k r l) e) = true -> + satisf rs ls (remove_equation (Eq k r l) e) -> + satisf (rs#r <- v) (Locmap.set l v' ls) e. +Proof. + intros; red; intros. + destruct (OrderedEquation.eq_dec q (Eq k r l)). + subst q; simpl. unfold l; rewrite Regmap.gss; rewrite Locmap.gss; auto. + assert (EqSet.In q (remove_equation {| ekind := k; ereg := r; eloc := l |} e)). + simpl. ESD.fsetdec. + exploit reg_loc_unconstrained_sound; eauto. intros [A B]. + rewrite Regmap.gso; auto. rewrite Locmap.gso; auto. +Qed. + +Lemma parallel_assignment_satisf_2: + forall rs ls res res' e e' v v', + remove_equations_res res res' e = Some e' -> + satisf rs ls e' -> + reg_unconstrained res e' = true -> + forallb (fun l => loc_unconstrained l e') (map R (regs_of_rpair res')) = true -> + Val.lessdef v v' -> + satisf (rs#res <- v) (Locmap.setpair res' v' ls) e. +Proof. + intros. functional inversion H. +- (* One location *) + subst. simpl in H2. InvBooleans. simpl. + apply parallel_assignment_satisf with Full; auto. + unfold reg_loc_unconstrained. rewrite H1, H4. auto. +- (* Two 32-bit halves *) + subst. + set (e' := remove_equation {| ekind := Low; ereg := res; eloc := R mr2 |} + (remove_equation {| ekind := High; ereg := res; eloc := R mr1 |} e)) in *. + simpl in H2. InvBooleans. simpl. + red; intros. + destruct (OrderedEquation.eq_dec q (Eq Low res (R mr2))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gss. + apply Val.loword_lessdef; auto. + destruct (OrderedEquation.eq_dec q (Eq High res (R mr1))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gso by auto. rewrite Locmap.gss. + apply Val.hiword_lessdef; auto. + assert (EqSet.In q e'). unfold e', remove_equation; simpl; ESD.fsetdec. + rewrite Regmap.gso. rewrite ! Locmap.gso. auto. + eapply loc_unconstrained_sound; eauto. + eapply loc_unconstrained_sound; eauto. + eapply reg_unconstrained_sound; eauto. +Qed. + +Remark in_elements_between_1: + forall r1 s q, + EqSet.In q (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) s) <-> EqSet.In q s /\ ereg q = r1. +Proof. + intros. rewrite EqSet.elements_between_iff, select_reg_charact. tauto. + exact (select_reg_l_monotone r1). exact (select_reg_h_monotone r1). +Qed. + +Lemma in_subst_reg: + forall r1 r2 q (e: eqs), + EqSet.In q e -> + ereg q = r1 /\ EqSet.In (Eq (ekind q) r2 (eloc q)) (subst_reg r1 r2 e) + \/ ereg q <> r1 /\ EqSet.In q (subst_reg r1 r2 e). +Proof. + intros r1 r2 q e0 IN0. unfold subst_reg. + set (f := fun (q: EqSet.elt) e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e)). + generalize (in_elements_between_1 r1 e0). + set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). + intros IN_ELT. + set (P := fun e1 e2 => + EqSet.In q e1 -> + EqSet.In (Eq (ekind q) r2 (eloc q)) e2). + assert (P elt (EqSet.fold f elt e0)). + { + apply ESP.fold_rec; unfold P; intros. + - ESD.fsetdec. + - simpl. red in H1. apply H1 in H3. destruct H3. + + subst x. ESD.fsetdec. + + rewrite ESF.add_iff. rewrite ESF.remove_iff. + destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := r2; eloc := eloc q |}); auto. + left. subst x; auto. + } + set (Q := fun e1 e2 => + ~EqSet.In q e1 -> + EqSet.In q e2). + assert (Q elt (EqSet.fold f elt e0)). + { + apply ESP.fold_rec; unfold Q; intros. + - auto. + - simpl. red in H2. rewrite H2 in H4. ESD.fsetdec. + } + destruct (ESP.In_dec q elt). + left. split. apply IN_ELT. auto. apply H. auto. + right. split. red; intros. elim n. rewrite IN_ELT. auto. apply H0. auto. +Qed. + +Lemma subst_reg_satisf: + forall src dst rs ls e, + satisf rs ls (subst_reg dst src e) -> + satisf (rs#dst <- (rs#src)) ls e. +Proof. + intros; red; intros. + destruct (in_subst_reg dst src q e H0) as [[A B] | [A B]]. + subst dst. rewrite Regmap.gss. exploit H; eauto. + rewrite Regmap.gso; auto. +Qed. + +Lemma in_subst_reg_kind: + forall r1 k1 r2 k2 q (e: eqs), + EqSet.In q e -> + (ereg q, ekind q) = (r1, k1) /\ EqSet.In (Eq k2 r2 (eloc q)) (subst_reg_kind r1 k1 r2 k2 e) + \/ EqSet.In q (subst_reg_kind r1 k1 r2 k2 e). +Proof. + intros r1 k1 r2 k2 q e0 IN0. unfold subst_reg. + set (f := fun (q: EqSet.elt) e => + if IndexedEqKind.eq (ekind q) k1 + then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e) + else e). + generalize (in_elements_between_1 r1 e0). + set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). + intros IN_ELT. + set (P := fun e1 e2 => + EqSet.In q e1 -> ekind q = k1 -> + EqSet.In (Eq k2 r2 (eloc q)) e2). + assert (P elt (EqSet.fold f elt e0)). + { + intros; apply ESP.fold_rec; unfold P; intros. + - ESD.fsetdec. + - simpl. red in H1. apply H1 in H3. destruct H3. + + subst x. unfold f. destruct (IndexedEqKind.eq (ekind q) k1). + simpl. ESD.fsetdec. contradiction. + + unfold f. destruct (IndexedEqKind.eq (ekind x) k1). + simpl. rewrite ESF.add_iff. rewrite ESF.remove_iff. + destruct (OrderedEquation.eq_dec x {| ekind := k2; ereg := r2; eloc := eloc q |}); auto. + left. subst x; auto. + auto. + } + set (Q := fun e1 e2 => + ~EqSet.In q e1 \/ ekind q <> k1 -> + EqSet.In q e2). + assert (Q elt (EqSet.fold f elt e0)). + { + apply ESP.fold_rec; unfold Q; intros. + - auto. + - unfold f. red in H2. rewrite H2 in H4. + destruct (IndexedEqKind.eq (ekind x) k1). + simpl. rewrite ESF.add_iff. rewrite ESF.remove_iff. + right. split. apply H3. tauto. intuition congruence. + apply H3. intuition auto. + } + destruct (ESP.In_dec q elt). + destruct (IndexedEqKind.eq (ekind q) k1). + left. split. f_equal. apply IN_ELT. auto. auto. apply H. auto. auto. + right. apply H0. auto. + right. apply H0. auto. +Qed. + +Lemma subst_reg_kind_satisf_makelong: + forall src1 src2 dst rs ls e, + let e1 := subst_reg_kind dst High src1 Full e in + let e2 := subst_reg_kind dst Low src2 Full e1 in + reg_unconstrained dst e2 = true -> + satisf rs ls e2 -> + satisf (rs#dst <- (Val.longofwords rs#src1 rs#src2)) ls e. +Proof. + intros; red; intros. + destruct (in_subst_reg_kind dst High src1 Full q e H1) as [[A B] | B]; fold e1 in B. + destruct (in_subst_reg_kind dst Low src2 Full _ e1 B) as [[C D] | D]; fold e2 in D. + simpl in C; simpl in D. inv C. + inversion A. rewrite H3; rewrite H4. rewrite Regmap.gss. + apply Val.lessdef_trans with (rs#src1). + simpl. destruct (rs#src1); simpl; auto. destruct (rs#src2); simpl; auto. + rewrite Int64.hi_ofwords. auto. + exploit H0. eexact D. simpl. auto. + destruct (in_subst_reg_kind dst Low src2 Full q e1 B) as [[C D] | D]; fold e2 in D. + inversion C. rewrite H3; rewrite H4. rewrite Regmap.gss. + apply Val.lessdef_trans with (rs#src2). + simpl. destruct (rs#src1); simpl; auto. destruct (rs#src2); simpl; auto. + rewrite Int64.lo_ofwords. auto. + exploit H0. eexact D. simpl. auto. + rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. +Qed. + +Lemma subst_reg_kind_satisf_lowlong: + forall src dst rs ls e, + let e1 := subst_reg_kind dst Full src Low e in + reg_unconstrained dst e1 = true -> + satisf rs ls e1 -> + satisf (rs#dst <- (Val.loword rs#src)) ls e. +Proof. + intros; red; intros. + destruct (in_subst_reg_kind dst Full src Low q e H1) as [[A B] | B]; fold e1 in B. + inversion A. rewrite H3; rewrite H4. simpl. rewrite Regmap.gss. + exploit H0. eexact B. simpl. auto. + rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. +Qed. + +Lemma subst_reg_kind_satisf_highlong: + forall src dst rs ls e, + let e1 := subst_reg_kind dst Full src High e in + reg_unconstrained dst e1 = true -> + satisf rs ls e1 -> + satisf (rs#dst <- (Val.hiword rs#src)) ls e. +Proof. + intros; red; intros. + destruct (in_subst_reg_kind dst Full src High q e H1) as [[A B] | B]; fold e1 in B. + inversion A. rewrite H3; rewrite H4. simpl. rewrite Regmap.gss. + exploit H0. eexact B. simpl. auto. + rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. +Qed. + +Module ESF2 := FSetFacts.Facts(EqSet2). +Module ESP2 := FSetProperties.Properties(EqSet2). +Module ESD2 := FSetDecide.Decide(EqSet2). + +Lemma partial_fold_ind: + forall (A: Type) (P: EqSet2.t -> A -> Prop) f init final s, + EqSet2.fold + (fun q opte => + match opte with + | None => None + | Some e => f q e + end) + s (Some init) = Some final -> + (forall s', EqSet2.Empty s' -> P s' init) -> + (forall x a' a'' s' s'', + EqSet2.In x s -> ~EqSet2.In x s' -> ESP2.Add x s' s'' -> + f x a' = Some a'' -> P s' a' -> P s'' a'') -> + P s final. +Proof. + intros. + set (g := fun q opte => match opte with Some e => f q e | None => None end) in *. + set (Q := fun s1 opte => match opte with None => True | Some e => P s1 e end). + change (Q s (Some final)). + rewrite <- H. apply ESP2.fold_rec; unfold Q, g; intros. + - auto. + - destruct a as [e|]; auto. destruct (f x e) as [e'|] eqn:F; auto. eapply H1; eauto. +Qed. + +Lemma in_subst_loc: + forall l1 l2 q (e e': eqs), + EqSet.In q e -> + subst_loc l1 l2 e = Some e' -> + (eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e') \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). +Proof. + unfold subst_loc; intros l1 l2 q e0 e0' IN SUBST. + set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. + set (f := fun q0 e => + if Loc.eq l1 (eloc q0) then + Some (add_equation + {| ekind := ekind q0; ereg := ereg q0; eloc := l2 |} + (remove_equation q0 e)) + else None). + set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e2). + assert (A: P elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold P; intros. ESD2.fsetdec. + - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + apply H1 in H4; destruct H4. + subst x; rewrite e; auto. + apply H3 in H2; destruct H2. split. congruence. + destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := ereg q; eloc := l2 |}); auto. + subst x; auto. + } + set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). + assert (B: Q elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold Q; intros. auto. + - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + red in H1. rewrite H1 in H4. intuition auto. } + destruct (ESP2.In_dec q elt). + left. apply A; auto. + right. split; auto. + rewrite <- select_loc_charact. + destruct (select_loc_l l1 q) eqn: LL; auto. + destruct (select_loc_h l1 q) eqn: LH; auto. + elim n. eapply EqSet2.elements_between_iff. + exact (select_loc_l_monotone l1). + exact (select_loc_h_monotone l1). + split. apply eqs_same; auto. auto. +Qed. + +Lemma loc_type_compat_charact: + forall env l e q, + loc_type_compat env l e = true -> + EqSet.In q e -> + subtype (sel_type (ekind q) (env (ereg q))) (Loc.type l) = true \/ Loc.diff l (eloc q). +Proof. + unfold loc_type_compat; intros. + rewrite EqSet2.for_all_between_iff in H. + destruct (select_loc_l l q) eqn: LL. + destruct (select_loc_h l q) eqn: LH. + left; apply H; auto. apply eqs_same; auto. + right. apply select_loc_charact. auto. + right. apply select_loc_charact. auto. + intros; subst; auto. + exact (select_loc_l_monotone l). + exact (select_loc_h_monotone l). +Qed. + +Lemma well_typed_move_charact: + forall env l e k r rs, + well_typed_move env l e = true -> + EqSet.In (Eq k r l) e -> + wt_regset env rs -> + match l with + | R mr => True + | S sl ofs ty => Val.has_type (sel_val k rs#r) ty + end. +Proof. + unfold well_typed_move; intros. + destruct l as [mr | sl ofs ty]. + auto. + exploit loc_type_compat_charact; eauto. intros [A | A]. + simpl in A. eapply Val.has_subtype; eauto. + generalize (H1 r). destruct k; simpl; intros. + auto. + destruct (rs#r); exact I. + destruct (rs#r); exact I. + eelim Loc.diff_not_eq. eexact A. auto. +Qed. + +Remark val_lessdef_normalize: + forall v v' ty, + Val.has_type v ty -> Val.lessdef v v' -> + Val.lessdef v (Val.load_result (chunk_of_type ty) v'). +Proof. + intros. inv H0. rewrite Val.load_result_same; auto. auto. +Qed. + +Lemma subst_loc_satisf: + forall env src dst rs ls e e', + subst_loc dst src e = Some e' -> + well_typed_move env dst e = true -> + wt_regset env rs -> + satisf rs ls e' -> + satisf rs (Locmap.set dst (ls src) ls) e. +Proof. + intros; red; intros. + exploit in_subst_loc; eauto. intros [[A B] | [A B]]. + subst dst. rewrite Locmap.gss. + destruct q as [k r l]; simpl in *. + exploit well_typed_move_charact; eauto. + destruct l as [mr | sl ofs ty]; intros. + apply (H2 _ B). + apply val_lessdef_normalize; auto. apply (H2 _ B). + rewrite Locmap.gso; auto. +Qed. + +Lemma in_subst_loc_part: + forall l1 l2 k q (e e': eqs), + EqSet.In q e -> + subst_loc_part l1 l2 k e = Some e' -> + (eloc q = l1 /\ ekind q = k /\ EqSet.In (Eq Full (ereg q) l2) e') \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). +Proof. + unfold subst_loc_part; intros l1 l2 k q e0 e0' IN SUBST. + set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. + set (f := fun q0 e => + if Loc.eq l1 (eloc q0) then + if IndexedEqKind.eq (ekind q0) k then + Some (add_equation + {| ekind := Full; ereg := ereg q0; eloc := l2 |} + (remove_equation q0 e)) + else None else None). + set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ ekind q = k /\ EqSet.In (Eq Full (ereg q) l2) e2). + assert (A: P elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold P; intros. ESD2.fsetdec. + - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); try discriminate. + destruct (IndexedEqKind.eq (ekind x) k); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + apply H1 in H4; destruct H4. + subst x; rewrite e, <- e1; auto. + apply H3 in H2; destruct H2 as (X & Y & Z). split; auto. split; auto. + destruct (OrderedEquation.eq_dec x {| ekind := Full; ereg := ereg q; eloc := l2 |}); auto. + subst x; auto. + } + set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). + assert (B: Q elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold Q; intros. auto. + - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); try congruence. + destruct (IndexedEqKind.eq (ekind x) k); inversion H2; subst a''; clear H2. + simpl. rewrite ESF.add_iff, ESF.remove_iff. + red in H1. rewrite H1 in H4. intuition auto. } + destruct (ESP2.In_dec q elt). + left. apply A; auto. + right. split; auto. + rewrite <- select_loc_charact. + destruct (select_loc_l l1 q) eqn: LL; auto. + destruct (select_loc_h l1 q) eqn: LH; auto. + elim n. eapply EqSet2.elements_between_iff. + exact (select_loc_l_monotone l1). + exact (select_loc_h_monotone l1). + split. apply eqs_same; auto. auto. +Qed. + +Lemma subst_loc_part_satisf_lowlong: + forall src dst rs ls e e', + subst_loc_part (R dst) (R src) Low e = Some e' -> + satisf rs ls e' -> + satisf rs (Locmap.set (R dst) (Val.loword (ls (R src))) ls) e. +Proof. + intros; red; intros. + exploit in_subst_loc_part; eauto. intros [[A [B C]] | [A B]]. + rewrite A, B. apply H0 in C. rewrite Locmap.gss. apply Val.loword_lessdef. exact C. + rewrite Locmap.gso; auto. +Qed. + +Lemma subst_loc_part_satisf_highlong: + forall src dst rs ls e e', + subst_loc_part (R dst) (R src) High e = Some e' -> + satisf rs ls e' -> + satisf rs (Locmap.set (R dst) (Val.hiword (ls (R src))) ls) e. +Proof. + intros; red; intros. + exploit in_subst_loc_part; eauto. intros [[A [B C]] | [A B]]. + rewrite A, B. apply H0 in C. rewrite Locmap.gss. apply Val.hiword_lessdef. exact C. + rewrite Locmap.gso; auto. +Qed. + +Lemma in_subst_loc_pair: + forall l1 l2 l2' q (e e': eqs), + EqSet.In q e -> + subst_loc_pair l1 l2 l2' e = Some e' -> + (eloc q = l1 /\ ekind q = Full /\ EqSet.In (Eq High (ereg q) l2) e' /\ EqSet.In (Eq Low (ereg q) l2') e') + \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). +Proof. + unfold subst_loc_pair; intros l1 l2 l2' q e0 e0' IN SUBST. + set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. + set (f := fun q0 e => + if Loc.eq l1 (eloc q0) then + if IndexedEqKind.eq (ekind q0) Full then + Some (add_equation {| ekind := High; ereg := ereg q0; eloc := l2 |} + (add_equation {| ekind := Low; ereg := ereg q0; eloc := l2' |} + (remove_equation q0 e))) + else None else None). + set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ ekind q = Full + /\ EqSet.In (Eq High (ereg q) l2) e2 + /\ EqSet.In (Eq Low (ereg q) l2') e2). + assert (A: P elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold P; intros. ESD2.fsetdec. + - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); try discriminate. + destruct (IndexedEqKind.eq (ekind x) Full); inversion H2; subst a''; clear H2. + simpl. rewrite ! ESF.add_iff, ! ESF.remove_iff. + apply H1 in H4; destruct H4. + subst x. rewrite e, e1. intuition auto. + apply H3 in H2; destruct H2 as (U & V & W & X). + destruct (OrderedEquation.eq_dec x {| ekind := High; ereg := ereg q; eloc := l2 |}). + subst x. intuition auto. + destruct (OrderedEquation.eq_dec x {| ekind := Low; ereg := ereg q; eloc := l2' |}). + subst x. intuition auto. + intuition auto. } + set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). + assert (B: Q elt e0'). + { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. + - unfold Q; intros. auto. + - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); try congruence. + destruct (IndexedEqKind.eq (ekind x) Full); inversion H2; subst a''; clear H2. + simpl. rewrite ! ESF.add_iff, ! ESF.remove_iff. + red in H1. rewrite H1 in H4. intuition auto. } + destruct (ESP2.In_dec q elt). + left. apply A; auto. + right. split; auto. + rewrite <- select_loc_charact. + destruct (select_loc_l l1 q) eqn: LL; auto. + destruct (select_loc_h l1 q) eqn: LH; auto. + elim n. eapply EqSet2.elements_between_iff. + exact (select_loc_l_monotone l1). + exact (select_loc_h_monotone l1). + split. apply eqs_same; auto. auto. +Qed. + +Lemma long_type_compat_charact: + forall env l e q, + long_type_compat env l e = true -> + EqSet.In q e -> + subtype (env (ereg q)) Tlong = true \/ Loc.diff l (eloc q). +Proof. + unfold long_type_compat; intros. + rewrite EqSet2.for_all_between_iff in H. + destruct (select_loc_l l q) eqn: LL. + destruct (select_loc_h l q) eqn: LH. + left; apply H; auto. apply eqs_same; auto. + right. apply select_loc_charact. auto. + right. apply select_loc_charact. auto. + intros; subst; auto. + exact (select_loc_l_monotone l). + exact (select_loc_h_monotone l). +Qed. + +Lemma subst_loc_pair_satisf_makelong: + forall env src1 src2 dst rs ls e e', + subst_loc_pair (R dst) (R src1) (R src2) e = Some e' -> + long_type_compat env (R dst) e = true -> + wt_regset env rs -> + satisf rs ls e' -> + Archi.ptr64 = false -> + satisf rs (Locmap.set (R dst) (Val.longofwords (ls (R src1)) (ls (R src2))) ls) e. +Proof. + intros; red; intros. + exploit in_subst_loc_pair; eauto. intros [[A [B [C D]]] | [A B]]. +- rewrite A, B. apply H2 in C. apply H2 in D. + assert (subtype (env (ereg q)) Tlong = true). + { exploit long_type_compat_charact; eauto. intros [P|P]; auto. + eelim Loc.diff_not_eq; eauto. } + rewrite Locmap.gss. simpl. rewrite <- (val_longofwords_eq_1 rs#(ereg q)). + apply Val.longofwords_lessdef. exact C. exact D. + eapply Val.has_subtype; eauto. + assumption. +- rewrite Locmap.gso; auto. +Qed. + +Lemma can_undef_sound: + forall e ml q, + can_undef ml e = true -> EqSet.In q e -> Loc.notin (eloc q) (map R ml). +Proof. + induction ml; simpl; intros. + tauto. + InvBooleans. split. + apply Loc.diff_sym. eapply loc_unconstrained_sound; eauto. + eauto. +Qed. + +Lemma undef_regs_outside: + forall ml ls l, + Loc.notin l (map R ml) -> undef_regs ml ls l = ls l. +Proof. + induction ml; simpl; intros. auto. + rewrite Locmap.gso. apply IHml. tauto. apply Loc.diff_sym. tauto. +Qed. + +Lemma can_undef_satisf: + forall ml e rs ls, + can_undef ml e = true -> + satisf rs ls e -> + satisf rs (undef_regs ml ls) e. +Proof. + intros; red; intros. rewrite undef_regs_outside. eauto. + eapply can_undef_sound; eauto. +Qed. + +Lemma can_undef_except_sound: + forall lx e ml q, + can_undef_except lx ml e = true -> EqSet.In q e -> Loc.diff (eloc q) lx -> Loc.notin (eloc q) (map R ml). +Proof. + induction ml; simpl; intros. + tauto. + InvBooleans. split. + destruct (orb_true_elim _ _ H2). + apply proj_sumbool_true in e0. congruence. + apply Loc.diff_sym. eapply loc_unconstrained_sound; eauto. + eapply IHml; eauto. +Qed. + +Lemma subst_loc_undef_satisf: + forall env src dst rs ls ml e e', + subst_loc dst src e = Some e' -> + well_typed_move env dst e = true -> + can_undef_except dst ml e = true -> + wt_regset env rs -> + satisf rs ls e' -> + satisf rs (Locmap.set dst (ls src) (undef_regs ml ls)) e. +Proof. + intros; red; intros. + exploit in_subst_loc; eauto. intros [[A B] | [A B]]. + subst dst. rewrite Locmap.gss. + destruct q as [k r l]; simpl in *. + exploit well_typed_move_charact; eauto. + destruct l as [mr | sl ofs ty]; intros. + apply (H3 _ B). + apply val_lessdef_normalize; auto. apply (H3 _ B). + rewrite Locmap.gso; auto. rewrite undef_regs_outside. eauto. + eapply can_undef_except_sound; eauto. apply Loc.diff_sym; auto. +Qed. + +Lemma transfer_use_def_satisf: + forall args res args' res' und e e' rs ls, + transfer_use_def args res args' res' und e = Some e' -> + satisf rs ls e' -> + Val.lessdef_list rs##args (reglist ls args') /\ + (forall v v', Val.lessdef v v' -> + satisf (rs#res <- v) (Locmap.set (R res') v' (undef_regs und ls)) e). +Proof. + unfold transfer_use_def; intros. MonadInv. + split. eapply add_equations_lessdef; eauto. + intros. eapply parallel_assignment_satisf; eauto. assumption. + eapply can_undef_satisf; eauto. + eapply add_equations_satisf; eauto. +Qed. + +Lemma add_equations_res_lessdef: + forall r ty l e e' rs ls, + add_equations_res r ty l e = Some e' -> + satisf rs ls e' -> + Val.has_type rs#r ty -> + Val.lessdef rs#r (Locmap.getpair (map_rpair R l) ls). +Proof. + intros. functional inversion H; simpl. +- subst. eapply add_equation_lessdef with (q := Eq Full r (R mr)); eauto. +- subst. rewrite <- (val_longofwords_eq_1 rs#r) by auto. + apply Val.longofwords_lessdef. + eapply add_equation_lessdef with (q := Eq High r (R mr1)). + eapply add_equation_satisf. eauto. + eapply add_equation_lessdef with (q := Eq Low r (R mr2)). + eauto. +Qed. + +Lemma return_regs_agree_callee_save: + forall caller callee, + agree_callee_save caller (return_regs caller callee). +Proof. + intros; red; intros. unfold return_regs. red in H. + destruct l. + rewrite H; auto. + destruct sl; auto || congruence. +Qed. + +Lemma no_caller_saves_sound: + forall e q, + no_caller_saves e = true -> + EqSet.In q e -> + callee_save_loc (eloc q). +Proof. + unfold no_caller_saves, callee_save_loc; intros. + exploit EqSet.for_all_2; eauto. + hnf. intros. simpl in H1. rewrite H1. auto. + lazy beta. destruct (eloc q). auto. destruct sl; congruence. +Qed. + +Lemma val_hiword_longofwords: + forall v1 v2, Val.lessdef (Val.hiword (Val.longofwords v1 v2)) v1. +Proof. + intros. destruct v1; simpl; auto. destruct v2; auto. unfold Val.hiword. + rewrite Int64.hi_ofwords. auto. +Qed. + +Lemma val_loword_longofwords: + forall v1 v2, Val.lessdef (Val.loword (Val.longofwords v1 v2)) v2. +Proof. + intros. destruct v1; simpl; auto. destruct v2; auto. unfold Val.loword. + rewrite Int64.lo_ofwords. auto. +Qed. + +Lemma function_return_satisf: + forall rs ls_before ls_after res res' sg e e' v, + res' = loc_result sg -> + remove_equations_res res res' e = Some e' -> + satisf rs ls_before e' -> + forallb (fun l => reg_loc_unconstrained res l e') (map R (regs_of_rpair res')) = true -> + no_caller_saves e' = true -> + Val.lessdef v (Locmap.getpair (map_rpair R res') ls_after) -> + agree_callee_save ls_before ls_after -> + satisf (rs#res <- v) ls_after e. +Proof. + intros; red; intros. + functional inversion H0. +- (* One register *) + subst. rewrite <- H8 in *. simpl in *. InvBooleans. + set (e' := remove_equation {| ekind := Full; ereg := res; eloc := R mr |} e) in *. + destruct (OrderedEquation.eq_dec q (Eq Full res (R mr))). + subst q; simpl. rewrite Regmap.gss; auto. + assert (EqSet.In q e'). unfold e', remove_equation; simpl. ESD.fsetdec. + exploit reg_loc_unconstrained_sound; eauto. intros [A B]. + rewrite Regmap.gso; auto. + exploit no_caller_saves_sound; eauto. intros. + red in H5. rewrite <- H5; auto. +- (* Two 32-bit halves *) + subst. rewrite <- H9 in *. simpl in *. + set (e' := remove_equation {| ekind := Low; ereg := res; eloc := R mr2 |} + (remove_equation {| ekind := High; ereg := res; eloc := R mr1 |} e)) in *. + InvBooleans. + destruct (OrderedEquation.eq_dec q (Eq Low res (R mr2))). + subst q; simpl. rewrite Regmap.gss. + eapply Val.lessdef_trans. apply Val.loword_lessdef. eauto. apply val_loword_longofwords. + destruct (OrderedEquation.eq_dec q (Eq High res (R mr1))). + subst q; simpl. rewrite Regmap.gss. + eapply Val.lessdef_trans. apply Val.hiword_lessdef. eauto. apply val_hiword_longofwords. + assert (EqSet.In q e'). unfold e', remove_equation; simpl; ESD.fsetdec. + exploit reg_loc_unconstrained_sound. eexact H. eauto. intros [A B]. + exploit reg_loc_unconstrained_sound. eexact H2. eauto. intros [C D]. + rewrite Regmap.gso; auto. + exploit no_caller_saves_sound; eauto. intros. + red in H5. rewrite <- H5; auto. +Qed. + +Lemma compat_left_sound: + forall r l e q, + compat_left r l e = true -> EqSet.In q e -> ereg q = r -> ekind q = Full /\ eloc q = l. +Proof. + unfold compat_left; intros. + rewrite EqSet.for_all_between_iff in H. + apply select_reg_charact in H1. destruct H1. + exploit H; eauto. intros. + destruct (ekind q); try discriminate. + destruct (Loc.eq l (eloc q)); try discriminate. + auto. + intros. subst x2. auto. + exact (select_reg_l_monotone r). + exact (select_reg_h_monotone r). +Qed. + +Lemma compat_left2_sound: + forall r l1 l2 e q, + compat_left2 r l1 l2 e = true -> EqSet.In q e -> ereg q = r -> + (ekind q = High /\ eloc q = l1) \/ (ekind q = Low /\ eloc q = l2). +Proof. + unfold compat_left2; intros. + rewrite EqSet.for_all_between_iff in H. + apply select_reg_charact in H1. destruct H1. + exploit H; eauto. intros. + destruct (ekind q); try discriminate. + InvBooleans. auto. + InvBooleans. auto. + intros. subst x2. auto. + exact (select_reg_l_monotone r). + exact (select_reg_h_monotone r). +Qed. + +Lemma compat_entry_satisf: + forall rl ll e, + compat_entry rl ll e = true -> + forall vl ls, + Val.lessdef_list vl (map (fun p => Locmap.getpair p ls) ll) -> + satisf (init_regs vl rl) ls e. +Proof. + intros until e. functional induction (compat_entry rl ll e); intros. +- (* no params *) + simpl. red; intros. rewrite Regmap.gi. destruct (ekind q); simpl; auto. +- (* a param in a single location *) + InvBooleans. simpl in H0. inv H0. simpl. + red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r1). + exploit compat_left_sound; eauto. intros [A B]. rewrite A; rewrite B; auto. + eapply IHb; eauto. +- (* a param split across two locations *) + InvBooleans. simpl in H0. inv H0. simpl. + red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r1). + exploit compat_left2_sound; eauto. + intros [[A B] | [A B]]; rewrite A; rewrite B; simpl. + apply Val.lessdef_trans with (Val.hiword (Val.longofwords (ls l1) (ls l2))). + apply Val.hiword_lessdef; auto. apply val_hiword_longofwords. + apply Val.lessdef_trans with (Val.loword (Val.longofwords (ls l1) (ls l2))). + apply Val.loword_lessdef; auto. apply val_loword_longofwords. + eapply IHb; eauto. +- (* error case *) + discriminate. +Qed. + +Lemma call_regs_param_values: + forall sg ls, + map (fun p => Locmap.getpair p (call_regs ls)) (loc_parameters sg) + = map (fun p => Locmap.getpair p ls) (loc_arguments sg). +Proof. + intros. unfold loc_parameters. rewrite list_map_compose. + apply list_map_exten; intros. symmetry. + assert (A: forall l, loc_argument_acceptable l -> call_regs ls (parameter_of_argument l) = ls l). + { destruct l as [r | [] ofs ty]; simpl; auto; contradiction. } + exploit loc_arguments_acceptable; eauto. destruct x; simpl; intros. +- auto. +- destruct H0; f_equal; auto. +Qed. + +Lemma return_regs_arg_values: + forall sg ls1 ls2, + tailcall_is_possible sg = true -> + map (fun p => Locmap.getpair p (return_regs ls1 ls2)) (loc_arguments sg) + = map (fun p => Locmap.getpair p ls2) (loc_arguments sg). +Proof. + intros. + apply tailcall_is_possible_correct in H. + apply list_map_exten; intros. + apply Locmap.getpair_exten; intros. + assert (In l (regs_of_rpairs (loc_arguments sg))) by (eapply in_regs_of_rpairs; eauto). + exploit loc_arguments_acceptable_2; eauto. exploit H; eauto. + destruct l; simpl; intros; try contradiction. rewrite H4; auto. +Qed. + +Lemma find_function_tailcall: + forall tge ros ls1 ls2, + ros_compatible_tailcall ros = true -> + find_function tge ros (return_regs ls1 ls2) = find_function tge ros ls2. +Proof. + unfold ros_compatible_tailcall, find_function; intros. + destruct ros as [r|id]; auto. + unfold return_regs. destruct (is_callee_save r). discriminate. auto. +Qed. + +Lemma loadv_int64_split: + forall m a v, + Mem.loadv Mint64 m a = Some v -> Archi.splitlong = true -> + exists v1 v2, + Mem.loadv Mint32 m a = Some (if Archi.big_endian then v1 else v2) + /\ Mem.loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) + /\ Val.lessdef (Val.hiword v) v1 + /\ Val.lessdef (Val.loword v) v2. +Proof. + intros. apply Archi.splitlong_ptr32 in H0. + exploit Mem.loadv_int64_split; eauto. intros (v1 & v2 & A & B & C). + exists v1, v2. split; auto. split; auto. + inv C; auto. destruct v1, v2; simpl; auto. + rewrite Int64.hi_ofwords, Int64.lo_ofwords; auto. +Qed. + +Lemma add_equations_builtin_arg_satisf: + forall env rs ls arg arg' e e', + add_equations_builtin_arg env arg arg' e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + induction arg; destruct arg'; simpl; intros; MonadInv; eauto. + eapply add_equation_satisf; eauto. + destruct arg'1; MonadInv. destruct arg'2; MonadInv. eauto using add_equation_satisf. +Qed. + +Lemma add_equations_builtin_arg_lessdef: + forall env (ge: RTL.genv) sp rs ls m arg v, + eval_builtin_arg ge (fun r => rs#r) sp m arg v -> + forall e e' arg', + add_equations_builtin_arg env arg arg' e = Some e' -> + satisf rs ls e' -> + wt_regset env rs -> + exists v', eval_builtin_arg ge ls sp m arg' v' /\ Val.lessdef v v'. +Proof. + induction 1; simpl; intros e e' arg' AE SAT WT; destruct arg'; MonadInv. +- exploit add_equation_lessdef; eauto. simpl; intros. + exists (ls x0); auto with barg. +- destruct arg'1; MonadInv. destruct arg'2; MonadInv. + exploit add_equation_lessdef. eauto. simpl; intros LD1. + exploit add_equation_lessdef. eapply add_equation_satisf. eauto. simpl; intros LD2. + exists (Val.longofwords (ls x0) (ls x1)); split; auto with barg. + rewrite <- (val_longofwords_eq_2 rs#x); auto. apply Val.longofwords_lessdef; auto. + rewrite <- e0; apply WT. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- econstructor; eauto with barg. +- exploit IHeval_builtin_arg1; eauto. eapply add_equations_builtin_arg_satisf; eauto. + intros (v1 & A & B). + exploit IHeval_builtin_arg2; eauto. intros (v2 & C & D). + exists (Val.longofwords v1 v2); split; auto with barg. apply Val.longofwords_lessdef; auto. +- exploit IHeval_builtin_arg1; eauto. eapply add_equations_builtin_arg_satisf; eauto. + intros (v1' & A & B). + exploit IHeval_builtin_arg2; eauto. intros (v2' & C & D). + econstructor; split. eauto with barg. + destruct Archi.ptr64; auto using Val.add_lessdef, Val.addl_lessdef. +Qed. + +Lemma add_equations_builtin_args_satisf: + forall env rs ls arg arg' e e', + add_equations_builtin_args env arg arg' e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + induction arg; destruct arg'; simpl; intros; MonadInv; eauto using add_equations_builtin_arg_satisf. +Qed. + +Lemma add_equations_builtin_args_lessdef: + forall env (ge: RTL.genv) sp rs ls m tm arg vl, + eval_builtin_args ge (fun r => rs#r) sp m arg vl -> + forall arg' e e', + add_equations_builtin_args env arg arg' e = Some e' -> + satisf rs ls e' -> + wt_regset env rs -> + Mem.extends m tm -> + exists vl', eval_builtin_args ge ls sp tm arg' vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 1; simpl; intros; destruct arg'; MonadInv. +- exists (@nil val); split; constructor. +- exploit IHlist_forall2; eauto. intros (vl' & A & B). + exploit add_equations_builtin_arg_lessdef; eauto. + eapply add_equations_builtin_args_satisf; eauto. intros (v1' & C & D). + exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). + exists (v1'' :: vl'); split; constructor; auto. eapply Val.lessdef_trans; eauto. +Qed. + +Lemma add_equations_debug_args_satisf: + forall env rs ls arg arg' e e', + add_equations_debug_args env arg arg' e = Some e' -> + satisf rs ls e' -> satisf rs ls e. +Proof. + induction arg; destruct arg'; simpl; intros; MonadInv; auto. + destruct (add_equations_builtin_arg env a b e) as [e1|] eqn:A; + eauto using add_equations_builtin_arg_satisf. +Qed. + +Lemma add_equations_debug_args_eval: + forall env (ge: RTL.genv) sp rs ls m tm arg vl, + eval_builtin_args ge (fun r => rs#r) sp m arg vl -> + forall arg' e e', + add_equations_debug_args env arg arg' e = Some e' -> + satisf rs ls e' -> + wt_regset env rs -> + Mem.extends m tm -> + exists vl', eval_builtin_args ge ls sp tm arg' vl'. +Proof. + induction 1; simpl; intros; destruct arg'; MonadInv. +- exists (@nil val); constructor. +- exists (@nil val); constructor. +- destruct (add_equations_builtin_arg env a1 b e) as [e1|] eqn:A. ++ exploit IHlist_forall2; eauto. intros (vl' & B). + exploit add_equations_builtin_arg_lessdef; eauto. + eapply add_equations_debug_args_satisf; eauto. intros (v1' & C & D). + exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). + exists (v1'' :: vl'); constructor; auto. ++ eauto. +Qed. + +Lemma add_equations_builtin_eval: + forall ef env args args' e1 e2 m1 m1' rs ls (ge: RTL.genv) sp vargs t vres m2, + wt_regset env rs -> + match ef with + | EF_debug _ _ _ => add_equations_debug_args env args args' e1 + | _ => add_equations_builtin_args env args args' e1 + end = Some e2 -> + Mem.extends m1 m1' -> + satisf rs ls e2 -> + eval_builtin_args ge (fun r => rs # r) sp m1 args vargs -> + external_call ef ge vargs m1 t vres m2 -> + satisf rs ls e1 /\ + exists vargs' vres' m2', + eval_builtin_args ge ls sp m1' args' vargs' + /\ external_call ef ge vargs' m1' t vres' m2' + /\ Val.lessdef vres vres' + /\ Mem.extends m2 m2'. +Proof. + intros. + assert (DEFAULT: add_equations_builtin_args env args args' e1 = Some e2 -> + satisf rs ls e1 /\ + exists vargs' vres' m2', + eval_builtin_args ge ls sp m1' args' vargs' + /\ external_call ef ge vargs' m1' t vres' m2' + /\ Val.lessdef vres vres' + /\ Mem.extends m2 m2'). + { + intros. split. eapply add_equations_builtin_args_satisf; eauto. + exploit add_equations_builtin_args_lessdef; eauto. + intros (vargs' & A & B). + exploit external_call_mem_extends; eauto. + intros (vres' & m2' & C & D & E & F). + exists vargs', vres', m2'; auto. + } + destruct ef; auto. + split. eapply add_equations_debug_args_satisf; eauto. + exploit add_equations_debug_args_eval; eauto. + intros (vargs' & A). + simpl in H4; inv H4. + exists vargs', Vundef, m1'. intuition auto. simpl. constructor. +Qed. + +Lemma parallel_set_builtin_res_satisf: + forall env res res' e0 e1 rs ls v v', + remove_equations_builtin_res env res res' e0 = Some e1 -> + forallb (fun r => reg_unconstrained r e1) (params_of_builtin_res res) = true -> + forallb (fun mr => loc_unconstrained (R mr) e1) (params_of_builtin_res res') = true -> + satisf rs ls e1 -> + Val.lessdef v v' -> + satisf (regmap_setres res v rs) (Locmap.setres res' v' ls) e0. +Proof. + intros. rewrite forallb_forall in *. + destruct res, res'; simpl in *; inv H. +- apply parallel_assignment_satisf with (k := Full); auto. + unfold reg_loc_unconstrained. rewrite H0 by auto. rewrite H1 by auto. auto. +- destruct res'1; try discriminate. destruct res'2; try discriminate. + rename x0 into hi; rename x1 into lo. MonadInv. destruct (mreg_eq hi lo); inv H5. + set (e' := remove_equation {| ekind := High; ereg := x; eloc := R hi |} e0) in *. + set (e'' := remove_equation {| ekind := Low; ereg := x; eloc := R lo |} e') in *. + simpl in *. red; intros. + destruct (OrderedEquation.eq_dec q (Eq Low x (R lo))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gss. apply Val.loword_lessdef; auto. + destruct (OrderedEquation.eq_dec q (Eq High x (R hi))). + subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gso by (red; auto). + rewrite Locmap.gss. apply Val.hiword_lessdef; auto. + assert (EqSet.In q e''). + { unfold e'', e', remove_equation; simpl; ESD.fsetdec. } + rewrite Regmap.gso. rewrite ! Locmap.gso. auto. + eapply loc_unconstrained_sound; eauto. + eapply loc_unconstrained_sound; eauto. + eapply reg_unconstrained_sound; eauto. +- auto. +Qed. + +(** * Properties of the dataflow analysis *) + +Lemma analyze_successors: + forall f env bsh an pc bs s e, + analyze f env bsh = Some an -> + bsh!pc = Some bs -> + In s (successors_block_shape bs) -> + an!!pc = OK e -> + exists e', transfer f env bsh s an!!s = OK e' /\ EqSet.Subset e' e. +Proof. + unfold analyze; intros. exploit DS.fixpoint_allnodes_solution; eauto. + rewrite H2. unfold DS.L.ge. destruct (transfer f env bsh s an#s); intros. + exists e0; auto. + contradiction. +Qed. + +Lemma satisf_successors: + forall f env bsh an pc bs s e rs ls, + analyze f env bsh = Some an -> + bsh!pc = Some bs -> + In s (successors_block_shape bs) -> + an!!pc = OK e -> + satisf rs ls e -> + exists e', transfer f env bsh s an!!s = OK e' /\ satisf rs ls e'. +Proof. + intros. exploit analyze_successors; eauto. intros [e' [A B]]. + exists e'; split; auto. eapply satisf_incr; eauto. +Qed. + +(** Inversion on [transf_function] *) + +Inductive transf_function_spec (f: RTL.function) (tf: LTL.function) : Prop := + | transf_function_spec_intro: + forall env an mv k e1 e2, + wt_function f env -> + analyze f env (pair_codes f tf) = Some an -> + (LTL.fn_code tf)!(LTL.fn_entrypoint tf) = Some(expand_moves mv (Lbranch (RTL.fn_entrypoint f) :: k)) -> + wf_moves mv -> + transfer f env (pair_codes f tf) (RTL.fn_entrypoint f) an!!(RTL.fn_entrypoint f) = OK e1 -> + track_moves env mv e1 = Some e2 -> + compat_entry (RTL.fn_params f) (loc_parameters (fn_sig tf)) e2 = true -> + can_undef destroyed_at_function_entry e2 = true -> + RTL.fn_stacksize f = LTL.fn_stacksize tf -> + RTL.fn_sig f = LTL.fn_sig tf -> + transf_function_spec f tf. + +Lemma transf_function_inv: + forall f tf, + transf_function f = OK tf -> + transf_function_spec f tf. +Proof. + unfold transf_function; intros. + destruct (type_function f) as [env|] eqn:TY; try discriminate. + destruct (regalloc f); try discriminate. + destruct (check_function f f0 env) as [] eqn:?; inv H. + unfold check_function in Heqr. + destruct (analyze f env (pair_codes f tf)) as [an|] eqn:?; try discriminate. + monadInv Heqr. + destruct (check_entrypoints_aux f tf env x) as [y|] eqn:?; try discriminate. + unfold check_entrypoints_aux, pair_entrypoints in Heqo0. MonadInv. + exploit extract_moves_ext_sound; eauto. intros [A B]. subst b. + exploit check_succ_sound; eauto. intros [k EQ1]. subst b0. + econstructor; eauto. eapply type_function_correct; eauto. congruence. +Qed. + +Lemma invert_code: + forall f env tf pc i opte e, + wt_function f env -> + (RTL.fn_code f)!pc = Some i -> + transfer f env (pair_codes f tf) pc opte = OK e -> + exists eafter, exists bsh, exists bb, + opte = OK eafter /\ + (pair_codes f tf)!pc = Some bsh /\ + (LTL.fn_code tf)!pc = Some bb /\ + expand_block_shape bsh i bb /\ + transfer_aux f env bsh eafter = Some e /\ + wt_instr f env i. +Proof. + intros. destruct opte as [eafter|]; simpl in H1; try discriminate. exists eafter. + destruct (pair_codes f tf)!pc as [bsh|] eqn:?; try discriminate. exists bsh. + exploit matching_instr_block; eauto. intros [bb [A B]]. + destruct (transfer_aux f env bsh eafter) as [e1|] eqn:?; inv H1. + exists bb. exploit wt_instr_at; eauto. + tauto. +Qed. + +(** * Semantic preservation *) + +Section PRESERVATION. + +Variable prog: RTL.program. +Variable tprog: LTL.program. +Hypothesis TRANSF: match_prog prog tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall (v: val) (f: RTL.fundef), + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial TRANSF). + +Lemma function_ptr_translated: + forall (b: block) (f: RTL.fundef), + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma sig_function_translated: + forall f tf, + transf_fundef f = OK tf -> + LTL.funsig tf = RTL.funsig f. +Proof. + intros; destruct f; monadInv H. + destruct (transf_function_inv _ _ EQ). simpl; auto. + auto. +Qed. + +Lemma find_function_translated: + forall ros rs fd ros' e e' ls, + RTL.find_function ge ros rs = Some fd -> + add_equation_ros ros ros' e = Some e' -> + satisf rs ls e' -> + exists tfd, + LTL.find_function tge ros' ls = Some tfd /\ transf_fundef fd = OK tfd. +Proof. + unfold RTL.find_function, LTL.find_function; intros. + destruct ros as [r|id]; destruct ros' as [r'|id']; simpl in H0; MonadInv. + (* two regs *) + exploit add_equation_lessdef; eauto. intros LD. inv LD. + eapply functions_translated; eauto. + rewrite <- H2 in H. simpl in H. congruence. + (* two symbols *) + rewrite symbols_preserved. rewrite Heqo. + eapply function_ptr_translated; eauto. +Qed. + +Lemma exec_moves: + forall mv env rs s f sp bb m e e' ls, + track_moves env mv e = Some e' -> + wf_moves mv -> + satisf rs ls e' -> + wt_regset env rs -> + exists ls', + star step tge (Block s f sp (expand_moves mv bb) ls m) + E0 (Block s f sp bb ls' m) + /\ satisf rs ls' e. +Proof. +Opaque destroyed_by_op. + induction mv; simpl; intros. + (* base *) +- unfold expand_moves; simpl. inv H. exists ls; split. apply star_refl. auto. + (* step *) +- assert (wf_moves mv) by (inv H0; auto). + destruct a; unfold expand_moves; simpl; MonadInv. ++ (* loc-loc move *) + destruct src as [rsrc | ssrc]; destruct dst as [rdst | sdst]. +* (* reg-reg *) + exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. simpl. eauto. auto. auto. +* (* reg->stack *) + exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. simpl. eauto. auto. +* (* stack->reg *) + simpl in Heqb. exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. auto. auto. +* (* stack->stack *) + inv H0. simpl in H6. contradiction. ++ (* makelong *) + exploit IHmv; eauto. eapply subst_loc_pair_satisf_makelong; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. simpl; eauto. reflexivity. traceEq. ++ (* lowlong *) + exploit IHmv; eauto. eapply subst_loc_part_satisf_lowlong; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. simpl; eauto. reflexivity. traceEq. ++ (* highlong *) + exploit IHmv; eauto. eapply subst_loc_part_satisf_highlong; eauto. + intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. + econstructor. simpl; eauto. reflexivity. traceEq. +Qed. + +(** The simulation relation *) + +Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> signature -> Prop := + | match_stackframes_nil: forall sg, + sg.(sig_res) = Tint -> + match_stackframes nil nil sg + | match_stackframes_cons: + forall res f sp pc rs s tf bb ls ts sg an e env + (STACKS: match_stackframes s ts (fn_sig tf)) + (FUN: transf_function f = OK tf) + (ANL: analyze f env (pair_codes f tf) = Some an) + (EQ: transfer f env (pair_codes f tf) pc an!!pc = OK e) + (WTF: wt_function f env) + (WTRS: wt_regset env rs) + (WTRES: env res = proj_sig_res sg) + (STEPS: forall v ls1 m, + Val.lessdef v (Locmap.getpair (map_rpair R (loc_result sg)) ls1) -> + Val.has_type v (env res) -> + agree_callee_save ls ls1 -> + exists ls2, + star LTL.step tge (Block ts tf sp bb ls1 m) + E0 (State ts tf sp pc ls2 m) + /\ satisf (rs#res <- v) ls2 e), + match_stackframes + (RTL.Stackframe res f sp pc rs :: s) + (LTL.Stackframe tf sp ls bb :: ts) + sg. + +Inductive match_states: RTL.state -> LTL.state -> Prop := + | match_states_intro: + forall s f sp pc rs m ts tf ls m' an e env + (STACKS: match_stackframes s ts (fn_sig tf)) + (FUN: transf_function f = OK tf) + (ANL: analyze f env (pair_codes f tf) = Some an) + (EQ: transfer f env (pair_codes f tf) pc an!!pc = OK e) + (SAT: satisf rs ls e) + (MEM: Mem.extends m m') + (WTF: wt_function f env) + (WTRS: wt_regset env rs), + match_states (RTL.State s f sp pc rs m) + (LTL.State ts tf sp pc ls m') + | match_states_call: + forall s f args m ts tf ls m' + (STACKS: match_stackframes s ts (funsig tf)) + (FUN: transf_fundef f = OK tf) + (ARGS: Val.lessdef_list args (map (fun p => Locmap.getpair p ls) (loc_arguments (funsig tf)))) + (AG: agree_callee_save (parent_locset ts) ls) + (MEM: Mem.extends m m') + (WTARGS: Val.has_type_list args (sig_args (funsig tf))), + match_states (RTL.Callstate s f args m) + (LTL.Callstate ts tf ls m') + | match_states_return: + forall s res m ts ls m' sg + (STACKS: match_stackframes s ts sg) + (RES: Val.lessdef res (Locmap.getpair (map_rpair R (loc_result sg)) ls)) + (AG: agree_callee_save (parent_locset ts) ls) + (MEM: Mem.extends m m') + (WTRES: Val.has_type res (proj_sig_res sg)), + match_states (RTL.Returnstate s res m) + (LTL.Returnstate ts ls m'). + +Lemma match_stackframes_change_sig: + forall s ts sg sg', + match_stackframes s ts sg -> + sg'.(sig_res) = sg.(sig_res) -> + match_stackframes s ts sg'. +Proof. + intros. inv H. + constructor. congruence. + econstructor; eauto. + unfold proj_sig_res in *. rewrite H0; auto. + intros. rewrite (loc_result_exten sg' sg) in H by auto. eauto. +Qed. + +Ltac UseShape := + match goal with + | [ WT: wt_function _ _, CODE: (RTL.fn_code _)!_ = Some _, EQ: transfer _ _ _ _ _ = OK _ |- _ ] => + destruct (invert_code _ _ _ _ _ _ _ WT CODE EQ) as (eafter & bsh & bb & AFTER & BSH & TCODE & EBS & TR & WTI); + inv EBS; unfold transfer_aux in TR; MonadInv + end. + +Remark addressing_not_long: + forall trap env f addr args dst s r, + wt_instr f env (Iload trap Mint64 addr args dst s) -> Archi.splitlong = true -> + In r args -> r <> dst. +Proof. + intros. inv H. + assert (A: forall ty, In ty (type_of_addressing addr) -> ty = Tptr). + { intros. destruct addr; simpl in H; intuition. } + assert (B: In (env r) (type_of_addressing addr)). + { rewrite <- H5. apply in_map; auto. } + assert (C: env r = Tint). + { apply A in B. rewrite B. unfold Tptr. rewrite Archi.splitlong_ptr32 by auto. auto. } + red; intros; subst r. rewrite C in H9; discriminate. +Qed. + +(** The proof of semantic preservation is a simulation argument of the + "plus" kind. *) + +Lemma step_simulation: + forall S1 t S2, RTL.step ge S1 t S2 -> wt_state S1 -> + forall S1', match_states S1 S1' -> + exists S2', plus LTL.step tge S1' t S2' /\ match_states S2 S2'. +Proof. + induction 1; intros WT S1' MS; inv MS; try UseShape. + +(* nop *) +- exploit exec_moves; eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + +(* op move *) +- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. + simpl in H0. inv H0. + exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. eapply subst_reg_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* op makelong *) +- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. + simpl in H0. inv H0. + exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + eapply subst_reg_kind_satisf_makelong. eauto. eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* op lowlong *) +- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. + simpl in H0. inv H0. + exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + eapply subst_reg_kind_satisf_lowlong. eauto. eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* op highlong *) +- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. + simpl in H0. inv H0. + exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + eapply subst_reg_kind_satisf_highlong. eauto. eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* op regular *) +- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit transfer_use_def_satisf; eauto. intros [X Y]. + exploit eval_operation_lessdef; eauto. intros [v' [F G]]. + exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. instantiate (1 := v'). rewrite <- F. + apply eval_operation_preserved. exact symbols_preserved. + eauto. eapply star_right. eexact A2. constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + +(* op dead *) +- exploit exec_moves; eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. + eapply reg_unconstrained_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + eapply wt_exec_Iop; eauto. + +(* load regular TRAP *) +- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit transfer_use_def_satisf; eauto. intros [X Y]. + exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. + exploit Mem.loadv_extends; eauto. intros [v' [P Q]]. + exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. instantiate (1 := a'). rewrite <- F. + apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. + eapply star_right. eexact A2. constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + +(* load pair *) +- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. + exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). + set (v2' := if Archi.big_endian then v2 else v1) in *. + set (v1' := if Archi.big_endian then v1 else v2) in *. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + assert (LD1: Val.lessdef_list rs##args (reglist ls1 args1')). + { eapply add_equations_lessdef; eauto. } + exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. + exploit Mem.loadv_extends. eauto. eexact LOAD1. eexact G1. intros (v1'' & LOAD1' & LD2). + set (ls2 := Locmap.set (R dst1') v1'' (undef_regs (destroyed_by_load Mint32 addr) ls1)). + assert (SAT2: satisf (rs#dst <- v) ls2 e2). + { eapply loc_unconstrained_satisf. eapply can_undef_satisf; eauto. + eapply reg_unconstrained_satisf. eauto. + eapply add_equations_satisf; eauto. assumption. + rewrite Regmap.gss. + apply Val.lessdef_trans with v1'; unfold sel_val; unfold kind_first_word; unfold v1'; destruct Archi.big_endian; auto. + } + exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. + assert (LD3: Val.lessdef_list rs##args (reglist ls3 args2')). + { replace (rs##args) with ((rs#dst<-v)##args). + eapply add_equations_lessdef; eauto. + apply list_map_exten; intros. rewrite Regmap.gso; auto. + eapply addressing_not_long; eauto. + } + exploit eval_addressing_lessdef. eexact LD3. + eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. + intros [a2' [F2 G2]]. + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a2' = Some v2'' /\ Val.lessdef v2' v2''). + { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G2]). } + destruct LOADX as (v2'' & LOAD2' & LD4). + set (ls4 := Locmap.set (R dst2') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls3)). + assert (SAT4: satisf (rs#dst <- v) ls4 e0). + { eapply loc_unconstrained_satisf. eapply can_undef_satisf; eauto. + eapply add_equations_satisf; eauto. assumption. + rewrite Regmap.gss. + apply Val.lessdef_trans with v2'; unfold sel_val; unfold kind_second_word; unfold v2'; destruct Archi.big_endian; auto. + } + exploit (exec_moves mv3); eauto. intros [ls5 [A5 B5]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. + instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. + eexact LOAD1'. instantiate (1 := ls2); auto. + eapply star_trans. eexact A3. + eapply star_left. econstructor. + instantiate (1 := a2'). rewrite <- F2. apply eval_addressing_preserved. exact symbols_preserved. + eexact LOAD2'. instantiate (1 := ls4); auto. + eapply star_right. eexact A5. + constructor. + eauto. eauto. eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. + econstructor; eauto. + +(* load first word of a pair *) +- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. + exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). + set (v2' := if Archi.big_endian then v2 else v1) in *. + set (v1' := if Archi.big_endian then v1 else v2) in *. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + assert (LD1: Val.lessdef_list rs##args (reglist ls1 args')). + { eapply add_equations_lessdef; eauto. } + exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. + exploit Mem.loadv_extends. eauto. eexact LOAD1. eexact G1. intros (v1'' & LOAD1' & LD2). + set (ls2 := Locmap.set (R dst') v1'' (undef_regs (destroyed_by_load Mint32 addr) ls1)). + assert (SAT2: satisf (rs#dst <- v) ls2 e0). + { eapply parallel_assignment_satisf; eauto. + apply Val.lessdef_trans with v1'; + unfold sel_val; unfold kind_first_word; unfold v1'; destruct Archi.big_endian; auto. + eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. + } + exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. + instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. + eexact LOAD1'. instantiate (1 := ls2); auto. + eapply star_right. eexact A3. + constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. + econstructor; eauto. + +(* load second word of a pair *) +- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. + exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). + set (v2' := if Archi.big_endian then v2 else v1) in *. + set (v1' := if Archi.big_endian then v1 else v2) in *. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + assert (LD1: Val.lessdef_list rs##args (reglist ls1 args')). + { eapply add_equations_lessdef; eauto. } + exploit eval_addressing_lessdef. eexact LD1. + eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. + intros [a1' [F1 G1]]. + assert (LOADX: exists v2'', Mem.loadv Mint32 m' a1' = Some v2'' /\ Val.lessdef v2' v2''). + { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G1]). } + destruct LOADX as (v2'' & LOAD2' & LD2). + set (ls2 := Locmap.set (R dst') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls1)). + assert (SAT2: satisf (rs#dst <- v) ls2 e0). + { eapply parallel_assignment_satisf; eauto. + apply Val.lessdef_trans with v2'; unfold sel_val; unfold kind_second_word; unfold v2'; destruct Archi.big_endian; auto. + eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. + } + exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. + instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. + eexact LOAD2'. instantiate (1 := ls2); auto. + eapply star_right. eexact A3. + constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. + econstructor; eauto. + +(* load dead *) +- exploit exec_moves; eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. + eapply reg_unconstrained_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + eapply wt_exec_Iload; eauto. + +- (* load notrap1 *) + generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). + intro WTRS'. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit transfer_use_def_satisf; eauto. intros [X Y]. + exploit eval_addressing_lessdef_none; eauto. intro Haddr. + exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. eapply exec_Lload_notrap1. rewrite <- Haddr. + apply eval_addressing_preserved. exact symbols_preserved. eauto. + + eapply star_right. eexact A2. constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + +(* load notrap1 dead *) +- exploit exec_moves; eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. + eapply reg_unconstrained_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + eapply wt_exec_Iload_notrap; eauto. + +(* load regular notrap2 *) +- generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). + intro WTRS'. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit transfer_use_def_satisf; eauto. intros [X Y]. + exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. + destruct (Mem.loadv chunk m' a') as [v' |] eqn:Hload. + { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. instantiate (1 := a'). rewrite <- F. + apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. + eapply star_right. eexact A2. constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + } + { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. eapply exec_Lload_notrap2. rewrite <- F. + apply eval_addressing_preserved. exact symbols_preserved. assumption. + eauto. + eapply star_right. eexact A2. constructor. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. + econstructor; eauto. + } + +- (* load notrap2 dead *) + exploit exec_moves; eauto. intros [ls1 [X Y]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact X. econstructor; eauto. + eauto. traceEq. + exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. + eapply reg_unconstrained_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + eapply wt_exec_Iload_notrap; eauto. + +(* store *) +- exploit exec_moves; eauto. intros [ls1 [X Y]]. + exploit add_equations_lessdef; eauto. intros LD. simpl in LD. inv LD. + exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. + exploit Mem.storev_extends; eauto. intros [m'' [P Q]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact X. + eapply star_two. econstructor. instantiate (1 := a'). rewrite <- F. + apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. + constructor. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + eapply can_undef_satisf; eauto. eapply add_equations_satisf; eauto. intros [enext [U V]]. + econstructor; eauto. + +(* store 2 *) +- assert (SF: Archi.ptr64 = false) by (apply Archi.splitlong_ptr32; auto). + exploit Mem.storev_int64_split; eauto. + replace (if Archi.big_endian then Val.hiword rs#src else Val.loword rs#src) + with (sel_val kind_first_word rs#src) + by (unfold kind_first_word; destruct Archi.big_endian; reflexivity). + replace (if Archi.big_endian then Val.loword rs#src else Val.hiword rs#src) + with (sel_val kind_second_word rs#src) + by (unfold kind_second_word; destruct Archi.big_endian; reflexivity). + intros [m1 [STORE1 STORE2]]. + exploit (exec_moves mv1); eauto. intros [ls1 [X Y]]. + exploit add_equations_lessdef. eexact Heqo1. eexact Y. intros LD1. + exploit add_equation_lessdef. eapply add_equations_satisf. eexact Heqo1. eexact Y. + simpl. intros LD2. + set (ls2 := undef_regs (destroyed_by_store Mint32 addr) ls1). + assert (SAT2: satisf rs ls2 e1). + eapply can_undef_satisf. eauto. + eapply add_equation_satisf. eapply add_equations_satisf; eauto. + exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. + assert (F1': eval_addressing tge sp addr (reglist ls1 args1') = Some a1'). + rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. + exploit Mem.storev_extends. eauto. eexact STORE1. eexact G1. eauto. + intros [m1' [STORE1' EXT1]]. + exploit (exec_moves mv2); eauto. intros [ls3 [U V]]. + exploit add_equations_lessdef. eexact Heqo. eexact V. intros LD3. + exploit add_equation_lessdef. eapply add_equations_satisf. eexact Heqo. eexact V. + simpl. intros LD4. + exploit eval_addressing_lessdef. eexact LD3. eauto. intros [a2' [F2 G2]]. + assert (F2': eval_addressing tge sp addr (reglist ls3 args2') = Some a2'). + rewrite <- F2. apply eval_addressing_preserved. exact symbols_preserved. + exploit (eval_offset_addressing tge); eauto. intros F2''. + assert (STOREX: exists m2', Mem.storev Mint32 m1' (Val.add a2' (Vint (Int.repr 4))) (ls3 (R src2')) = Some m2' /\ Mem.extends m' m2'). + { try discriminate; + (eapply Mem.storev_extends; + [eexact EXT1 | eexact STORE2 | apply Val.add_lessdef; [eexact G2|eauto] | eauto]). } + destruct STOREX as [m2' [STORE2' EXT2]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact X. + eapply star_left. + econstructor. eexact F1'. eexact STORE1'. instantiate (1 := ls2). auto. + eapply star_trans. eexact U. + eapply star_two. + eapply exec_Lstore with (m' := m2'). eexact F2''. discriminate||exact STORE2'. eauto. + constructor. eauto. eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + eapply can_undef_satisf. eauto. + eapply add_equation_satisf. eapply add_equations_satisf; eauto. + intros [enext [P Q]]. + econstructor; eauto. + +(* call *) +- set (sg := RTL.funsig fd) in *. + set (args' := loc_arguments sg) in *. + set (res' := loc_result sg) in *. + exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit find_function_translated. eauto. eauto. eapply add_equations_args_satisf; eauto. + intros [tfd [E F]]. + assert (SIG: funsig tfd = sg). eapply sig_function_translated; eauto. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. econstructor; eauto. + eauto. traceEq. + exploit analyze_successors; eauto. simpl. left; eauto. intros [enext [U V]]. + econstructor; eauto. + econstructor; eauto. + inv WTI. congruence. + intros. exploit (exec_moves mv2). eauto. eauto. + eapply function_return_satisf with (v := v) (ls_before := ls1) (ls_after := ls0); eauto. + eapply add_equation_ros_satisf; eauto. + eapply add_equations_args_satisf; eauto. + congruence. + apply wt_regset_assign; auto. + intros [ls2 [A2 B2]]. + exists ls2; split. + eapply star_right. eexact A2. constructor. traceEq. + apply satisf_incr with eafter; auto. + rewrite SIG. eapply add_equations_args_lessdef; eauto. + inv WTI. rewrite <- H7. apply wt_regset_list; auto. + simpl. red; auto. + inv WTI. rewrite SIG. rewrite <- H7. apply wt_regset_list; auto. + +(* tailcall *) +- set (sg := RTL.funsig fd) in *. + set (args' := loc_arguments sg) in *. + exploit Mem.free_parallel_extends; eauto. intros [m'' [P Q]]. + exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. + exploit find_function_translated. eauto. eauto. eapply add_equations_args_satisf; eauto. + intros [tfd [E F]]. + assert (SIG: funsig tfd = sg). eapply sig_function_translated; eauto. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. econstructor; eauto. + rewrite <- E. apply find_function_tailcall; auto. + replace (fn_stacksize tf) with (RTL.fn_stacksize f); eauto. + destruct (transf_function_inv _ _ FUN); auto. + eauto. traceEq. + econstructor; eauto. + eapply match_stackframes_change_sig; eauto. rewrite SIG. rewrite e0. decEq. + destruct (transf_function_inv _ _ FUN); auto. + rewrite SIG. rewrite return_regs_arg_values; auto. eapply add_equations_args_lessdef; eauto. + inv WTI. rewrite <- H6. apply wt_regset_list; auto. + apply return_regs_agree_callee_save. + rewrite SIG. inv WTI. rewrite <- H6. apply wt_regset_list; auto. + +(* builtin *) +- exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. + exploit add_equations_builtin_eval; eauto. + intros (C & vargs' & vres' & m'' & D & E & F & G). + assert (WTRS': wt_regset env (regmap_setres res vres rs)) by (eapply wt_exec_Ibuiltin; eauto). + set (ls2 := Locmap.setres res' vres' (undef_regs (destroyed_by_builtin ef) ls1)). + assert (satisf (regmap_setres res vres rs) ls2 e0). + { eapply parallel_set_builtin_res_satisf; eauto. + eapply can_undef_satisf; eauto. } + exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_trans. eexact A1. + eapply star_left. econstructor. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. eauto. + instantiate (1 := ls2); auto. + eapply star_right. eexact A3. + econstructor. + reflexivity. reflexivity. reflexivity. traceEq. + exploit satisf_successors; eauto. simpl; eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* cond *) +- exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. + econstructor. eapply eval_condition_lessdef; eauto. eapply add_equations_lessdef; eauto. + eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. + instantiate (1 := if b then ifso else ifnot). simpl. destruct b; auto. + eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* jumptable *) +- exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. + assert (Val.lessdef (Vint n) (ls1 (R arg'))). + rewrite <- H0. eapply add_equation_lessdef with (q := Eq Full arg (R arg')); eauto. + inv H2. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. + econstructor. eauto. eauto. eauto. eauto. traceEq. + exploit satisf_successors; eauto. + instantiate (1 := pc'). simpl. eapply list_nth_z_in; eauto. + eapply can_undef_satisf. eauto. eapply add_equation_satisf; eauto. + intros [enext [U V]]. + econstructor; eauto. + +(* return *) +- destruct (transf_function_inv _ _ FUN). + exploit Mem.free_parallel_extends; eauto. rewrite H10. intros [m'' [P Q]]. + inv WTI; MonadInv. ++ (* without an argument *) + exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. + econstructor. eauto. eauto. traceEq. + simpl. econstructor; eauto. + apply return_regs_agree_callee_save. + constructor. ++ (* with an argument *) + exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_right. eexact A1. + econstructor. eauto. eauto. traceEq. + simpl. econstructor; eauto. rewrite <- H11. + replace (Locmap.getpair (map_rpair R (loc_result (RTL.fn_sig f))) + (return_regs (parent_locset ts) ls1)) + with (Locmap.getpair (map_rpair R (loc_result (RTL.fn_sig f))) ls1). + eapply add_equations_res_lessdef; eauto. + rewrite <- H14. apply WTRS. + generalize (loc_result_caller_save (RTL.fn_sig f)). + destruct (loc_result (RTL.fn_sig f)); simpl. + intros A; rewrite A; auto. + intros [A B]; rewrite A, B; auto. + apply return_regs_agree_callee_save. + rewrite <- H11, <- H14. apply WTRS. + +(* internal function *) +- monadInv FUN. simpl in *. + destruct (transf_function_inv _ _ EQ). + exploit Mem.alloc_extends; eauto. apply Z.le_refl. rewrite H8; apply Z.le_refl. + intros [m'' [U V]]. + assert (WTRS: wt_regset env (init_regs args (fn_params f))). + { apply wt_init_regs. inv H0. rewrite wt_params. rewrite H9. auto. } + exploit (exec_moves mv). eauto. eauto. + eapply can_undef_satisf; eauto. eapply compat_entry_satisf; eauto. + rewrite call_regs_param_values. eexact ARGS. + exact WTRS. + intros [ls1 [A B]]. + econstructor; split. + eapply plus_left. econstructor; eauto. + eapply star_left. econstructor; eauto. + eapply star_right. eexact A. + econstructor; eauto. + eauto. eauto. traceEq. + econstructor; eauto. + +(* external function *) +- exploit external_call_mem_extends; eauto. intros [v' [m'' [F [G [J K]]]]]. + simpl in FUN; inv FUN. + econstructor; split. + apply plus_one. econstructor; eauto. + eapply external_call_symbols_preserved with (ge1 := ge); eauto. apply senv_preserved. + econstructor; eauto. + simpl. destruct (loc_result (ef_sig ef)) eqn:RES; simpl. + rewrite Locmap.gss; auto. + generalize (loc_result_pair (ef_sig ef)); rewrite RES; intros (A & B & C & D & E). + assert (WTRES': Val.has_type v' Tlong). + { rewrite <- B. eapply external_call_well_typed; eauto. } + rewrite Locmap.gss. rewrite Locmap.gso by (red; auto). rewrite Locmap.gss. + rewrite val_longofwords_eq_1 by auto. auto. + red; intros. rewrite (AG l H0). + rewrite locmap_get_set_loc_result_callee_save by auto. + unfold undef_caller_save_regs. destruct l; simpl in H0. + rewrite H0; auto. + destruct sl; auto; congruence. + eapply external_call_well_typed; eauto. + +(* return *) +- inv STACKS. + exploit STEPS; eauto. rewrite WTRES0; auto. intros [ls2 [A B]]. + econstructor; split. + eapply plus_left. constructor. eexact A. traceEq. + econstructor; eauto. + apply wt_regset_assign; auto. rewrite WTRES0; auto. +Qed. + +Lemma initial_states_simulation: + forall st1, RTL.initial_state prog st1 -> + exists st2, LTL.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + exploit sig_function_translated; eauto. intros SIG. + exists (LTL.Callstate nil tf (Locmap.init Vundef) m0); split. + econstructor; eauto. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + rewrite symbols_preserved. + rewrite (match_program_main TRANSF). auto. + congruence. + constructor; auto. + constructor. rewrite SIG; rewrite H3; auto. + rewrite SIG, H3, loc_arguments_main. auto. + red; auto. + apply Mem.extends_refl. + rewrite SIG, H3. constructor. +Qed. + +Lemma final_states_simulation: + forall st1 st2 r, + match_states st1 st2 -> RTL.final_state st1 r -> LTL.final_state st2 r. +Proof. + intros. inv H0. inv H. inv STACKS. + econstructor. rewrite <- (loc_result_exten sg). inv RES; auto. + rewrite H; auto. +Qed. + +Lemma wt_prog: wt_program prog. +Proof. + red; intros. + exploit list_forall2_in_left. eexact (proj1 TRANSF). eauto. + intros ([i' gd] & A & B & C). simpl in *; subst i'. + inv C. destruct f; simpl in *. +- monadInv H2. + unfold transf_function in EQ. + destruct (type_function f) as [env|] eqn:TF; try discriminate. + econstructor. eapply type_function_correct; eauto. +- constructor. +Qed. + +Theorem transf_program_correct: + forward_simulation (RTL.semantics prog) (LTL.semantics tprog). +Proof. + set (ms := fun s s' => wt_state s /\ match_states s s'). + eapply forward_simulation_plus with (match_states := ms). +- apply senv_preserved. +- intros. exploit initial_states_simulation; eauto. intros [st2 [A B]]. + exists st2; split; auto. split; auto. + apply wt_initial_state with (p := prog); auto. exact wt_prog. +- intros. destruct H. eapply final_states_simulation; eauto. +- intros. destruct H0. + exploit step_simulation; eauto. intros [s2' [A B]]. + exists s2'; split. exact A. split. + eapply subject_reduction; eauto. eexact wt_prog. eexact H. + auto. +Qed. + +End PRESERVATION. diff --git a/backend/Allocproof.v b/backend/Allocproof.v deleted file mode 100644 index 3c7df58a..00000000 --- a/backend/Allocproof.v +++ /dev/null @@ -1,2619 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for the [Allocation] pass (validated translation from - RTL to LTL). *) - -Require Import FunInd. -Require Import FSets. -Require Import Coqlib Ordered Maps Errors Integers Floats. -Require Import AST Linking Lattice Kildall. -Require Import Values Memory Globalenvs Events Smallstep. -Require Archi. -Require Import Op Registers RTL Locations Conventions RTLtyping LTL. -Require Import Allocation. - -Definition match_prog (p: RTL.program) (tp: LTL.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -(** * Soundness of structural checks *) - -Definition expand_move (m: move) : instruction := - match m with - | MV (R src) (R dst) => Lop Omove (src::nil) dst - | MV (S sl ofs ty) (R dst) => Lgetstack sl ofs ty dst - | MV (R src) (S sl ofs ty) => Lsetstack src sl ofs ty - | MV (S _ _ _) (S _ _ _) => Lreturn (**r should never happen *) - | MVmakelong src1 src2 dst => Lop Omakelong (src1::src2::nil) dst - | MVlowlong src dst => Lop Olowlong (src::nil) dst - | MVhighlong src dst => Lop Ohighlong (src::nil) dst - end. - -Definition expand_moves (mv: moves) (k: bblock) : bblock := - List.map expand_move mv ++ k. - -Definition wf_move (m: move) : Prop := - match m with - | MV (S _ _ _) (S _ _ _) => False - | _ => True - end. - -Definition wf_moves (mv: moves) : Prop := - List.Forall wf_move mv. - -Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Prop := - | ebs_nop: forall mv s k, - wf_moves mv -> - expand_block_shape (BSnop mv s) - (Inop s) - (expand_moves mv (Lbranch s :: k)) - | ebs_move: forall src dst mv s k, - wf_moves mv -> - expand_block_shape (BSmove src dst mv s) - (Iop Omove (src :: nil) dst s) - (expand_moves mv (Lbranch s :: k)) - | ebs_makelong: forall src1 src2 dst mv s k, - wf_moves mv -> - Archi.splitlong = true -> - expand_block_shape (BSmakelong src1 src2 dst mv s) - (Iop Omakelong (src1 :: src2 :: nil) dst s) - (expand_moves mv (Lbranch s :: k)) - | ebs_lowlong: forall src dst mv s k, - wf_moves mv -> - Archi.splitlong = true -> - expand_block_shape (BSlowlong src dst mv s) - (Iop Olowlong (src :: nil) dst s) - (expand_moves mv (Lbranch s :: k)) - | ebs_highlong: forall src dst mv s k, - wf_moves mv -> - Archi.splitlong = true -> - expand_block_shape (BShighlong src dst mv s) - (Iop Ohighlong (src :: nil) dst s) - (expand_moves mv (Lbranch s :: k)) - | ebs_op: forall op args res mv1 args' res' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - expand_block_shape (BSop op args res mv1 args' res' mv2 s) - (Iop op args res s) - (expand_moves mv1 - (Lop op args' res' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_op_dead: forall op args res mv s k, - wf_moves mv -> - expand_block_shape (BSopdead op args res mv s) - (Iop op args res s) - (expand_moves mv (Lbranch s :: k)) - | ebs_load: forall trap chunk addr args dst mv1 args' dst' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - expand_block_shape (BSload trap chunk addr args dst mv1 args' dst' mv2 s) - (Iload trap chunk addr args dst s) - (expand_moves mv1 - (Lload trap chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_load2: forall addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s k, - wf_moves mv1 -> wf_moves mv2 -> wf_moves mv3 -> - Archi.splitlong = true -> - offset_addressing addr 4 = Some addr2 -> - expand_block_shape (BSload2 addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s) - (Iload TRAP Mint64 addr args dst s) - (expand_moves mv1 - (Lload TRAP Mint32 addr args1' dst1' :: - expand_moves mv2 - (Lload TRAP Mint32 addr2 args2' dst2' :: - expand_moves mv3 (Lbranch s :: k)))) - | ebs_load2_1: forall addr args dst mv1 args' dst' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - Archi.splitlong = true -> - expand_block_shape (BSload2_1 addr args dst mv1 args' dst' mv2 s) - (Iload TRAP Mint64 addr args dst s) - (expand_moves mv1 - (Lload TRAP Mint32 addr args' dst' :: - expand_moves mv2 (Lbranch s :: k))) - | ebs_load2_2: forall addr addr2 args dst mv1 args' dst' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - Archi.splitlong = true -> - offset_addressing addr 4 = Some addr2 -> - expand_block_shape (BSload2_2 addr addr2 args dst mv1 args' dst' mv2 s) - (Iload TRAP Mint64 addr args dst s) - (expand_moves mv1 - (Lload TRAP Mint32 addr2 args' dst' :: - expand_moves mv2 (Lbranch s :: k))) - | ebs_load_dead: forall trap chunk addr args dst mv s k, - wf_moves mv -> - expand_block_shape (BSloaddead chunk addr args dst mv s) - (Iload trap chunk addr args dst s) - (expand_moves mv (Lbranch s :: k)) - | ebs_store: forall chunk addr args src mv1 args' src' s k, - wf_moves mv1 -> - expand_block_shape (BSstore chunk addr args src mv1 args' src' s) - (Istore chunk addr args src s) - (expand_moves mv1 - (Lstore chunk addr args' src' :: Lbranch s :: k)) - | ebs_store2: forall addr addr2 args src mv1 args1' src1' mv2 args2' src2' s k, - wf_moves mv1 -> wf_moves mv2 -> - Archi.splitlong = true -> - offset_addressing addr 4 = Some addr2 -> - expand_block_shape (BSstore2 addr addr2 args src mv1 args1' src1' mv2 args2' src2' s) - (Istore Mint64 addr args src s) - (expand_moves mv1 - (Lstore Mint32 addr args1' src1' :: - expand_moves mv2 - (Lstore Mint32 addr2 args2' src2' :: - Lbranch s :: k))) - | ebs_call: forall sg ros args res mv1 ros' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - expand_block_shape (BScall sg ros args res mv1 ros' mv2 s) - (Icall sg ros args res s) - (expand_moves mv1 - (Lcall sg ros' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_tailcall: forall sg ros args mv ros' k, - wf_moves mv -> - expand_block_shape (BStailcall sg ros args mv ros') - (Itailcall sg ros args) - (expand_moves mv (Ltailcall sg ros' :: k)) - | ebs_builtin: forall ef args res mv1 args' res' mv2 s k, - wf_moves mv1 -> wf_moves mv2 -> - expand_block_shape (BSbuiltin ef args res mv1 args' res' mv2 s) - (Ibuiltin ef args res s) - (expand_moves mv1 - (Lbuiltin ef args' res' :: expand_moves mv2 (Lbranch s :: k))) - | ebs_cond: forall cond args mv args' s1 s2 k i i', - wf_moves mv -> - expand_block_shape (BScond cond args mv args' s1 s2) - (Icond cond args s1 s2 i) - (expand_moves mv (Lcond cond args' s1 s2 i' :: k)) - | ebs_jumptable: forall arg mv arg' tbl k, - wf_moves mv -> - expand_block_shape (BSjumptable arg mv arg' tbl) - (Ijumptable arg tbl) - (expand_moves mv (Ljumptable arg' tbl :: k)) - | ebs_return: forall optarg mv k, - wf_moves mv -> - expand_block_shape (BSreturn optarg mv) - (Ireturn optarg) - (expand_moves mv (Lreturn :: k)). - -Ltac MonadInv := - match goal with - | [ H: match ?x with Some _ => _ | None => None end = Some _ |- _ ] => - destruct x as [] eqn:? ; [MonadInv|discriminate] - | [ H: match ?x with left _ => _ | right _ => None end = Some _ |- _ ] => - destruct x; [MonadInv|discriminate] - | [ H: match negb (proj_sumbool ?x) with true => _ | false => None end = Some _ |- _ ] => - destruct x; [discriminate|simpl in H; MonadInv] - | [ H: match negb ?x with true => _ | false => None end = Some _ |- _ ] => - destruct x as [] eqn:? ; [discriminate|simpl in H; MonadInv] - | [ H: match ?x with true => _ | false => None end = Some _ |- _ ] => - destruct x as [] eqn:? ; [MonadInv|discriminate] - | [ H: match ?x with (_, _) => _ end = Some _ |- _ ] => - destruct x as [] eqn:? ; MonadInv - | [ H: Some _ = Some _ |- _ ] => - inv H; MonadInv - | [ H: None = Some _ |- _ ] => - discriminate - | _ => - idtac - end. - -Remark expand_moves_cons: - forall m accu b, - expand_moves (rev (m :: accu)) b = expand_moves (rev accu) (expand_move m :: b). -Proof. - unfold expand_moves; intros. simpl. rewrite map_app. rewrite app_ass. auto. -Qed. - -Lemma extract_moves_sound: - forall b mv b', - extract_moves nil b = (mv, b') -> - wf_moves mv /\ b = expand_moves mv b'. -Proof. - assert (BASE: - forall accu b, - wf_moves accu -> - wf_moves (List.rev accu) /\ expand_moves (List.rev accu) b = expand_moves (List.rev accu) b). - { intros; split; auto. unfold wf_moves in *; rewrite Forall_forall in *. - intros. apply H. rewrite <- in_rev in H0; auto. } - - assert (IND: forall b accu mv b', - extract_moves accu b = (mv, b') -> - wf_moves accu -> - wf_moves mv /\ expand_moves (List.rev accu) b = expand_moves mv b'). - { induction b; simpl; intros. - - inv H. auto. - - destruct a; try (inv H; apply BASE; auto; fail). - + destruct (is_move_operation op args) as [arg|] eqn:E. - exploit is_move_operation_correct; eauto. intros [A B]; subst. - (* reg-reg move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - inv H; apply BASE; auto. - + (* stack-reg move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - + (* reg-stack move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - } - intros. exploit IND; eauto. constructor. -Qed. - -Lemma extract_moves_ext_sound: - forall b mv b', - extract_moves_ext nil b = (mv, b') -> - wf_moves mv /\ b = expand_moves mv b'. -Proof. - assert (BASE: - forall accu b, - wf_moves accu -> - wf_moves (List.rev accu) /\ expand_moves (List.rev accu) b = expand_moves (List.rev accu) b). - { intros; split; auto. unfold wf_moves in *; rewrite Forall_forall in *. - intros. apply H. rewrite <- in_rev in H0; auto. } - - assert (IND: forall b accu mv b', - extract_moves_ext accu b = (mv, b') -> - wf_moves accu -> - wf_moves mv /\ expand_moves (List.rev accu) b = expand_moves mv b'). - { induction b; simpl; intros. - - inv H. auto. - - destruct a; try (inv H; apply BASE; auto; fail). - + destruct (classify_operation op args). - * (* reg-reg move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - * (* makelong *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - * (* lowlong *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - * (* highlong *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - * (* default *) - inv H; apply BASE; auto. - + (* stack-reg move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - + (* reg-stack move *) - exploit IHb; eauto. constructor; auto. exact I. rewrite expand_moves_cons; auto. - } - intros. exploit IND; eauto. constructor. -Qed. - -Lemma check_succ_sound: - forall s b, check_succ s b = true -> exists k, b = Lbranch s :: k. -Proof. - intros. destruct b; simpl in H; try discriminate. - destruct i; try discriminate. - destruct (peq s s0); simpl in H; inv H. exists b; auto. -Qed. - -Ltac UseParsingLemmas := - match goal with - | [ H: extract_moves nil _ = (_, _) |- _ ] => - destruct (extract_moves_sound _ _ _ H); clear H; subst; UseParsingLemmas - | [ H: extract_moves_ext nil _ = (_, _) |- _ ] => - destruct (extract_moves_ext_sound _ _ _ H); clear H; subst; UseParsingLemmas - | [ H: check_succ _ _ = true |- _ ] => - try (discriminate H); - destruct (check_succ_sound _ _ H); clear H; subst; UseParsingLemmas - | _ => idtac - end. - -Lemma pair_instr_block_sound: - forall i b bsh, - pair_instr_block i b = Some bsh -> expand_block_shape bsh i b. -Proof. - assert (OP: forall op args res s b bsh, - pair_Iop_block op args res s b = Some bsh -> expand_block_shape bsh (Iop op args res s) b). - { - unfold pair_Iop_block; intros. MonadInv. destruct b0. - MonadInv; UseParsingLemmas. - destruct i; MonadInv; UseParsingLemmas. - eapply ebs_op; eauto. - inv H0. eapply ebs_op_dead; eauto. } - - intros; destruct i; simpl in H; MonadInv; UseParsingLemmas. -- (* nop *) - econstructor; eauto. -- (* op *) - destruct (classify_operation o l). -+ (* move *) - MonadInv; UseParsingLemmas. econstructor; eauto. -+ (* makelong *) - destruct Archi.splitlong eqn:SL; eauto. - MonadInv; UseParsingLemmas. econstructor; eauto. -+ (* lowlong *) - destruct Archi.splitlong eqn:SL; eauto. - MonadInv; UseParsingLemmas. econstructor; eauto. -+ (* highlong *) - destruct Archi.splitlong eqn:SL; eauto. - MonadInv; UseParsingLemmas. econstructor; eauto. -+ (* other ops *) - eauto. -- (* load *) - destruct b0 as [ | [] b0]; MonadInv; UseParsingLemmas. - destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. - destruct b as [ | [] b]; MonadInv; UseParsingLemmas. - InvBooleans. subst m. eapply ebs_load2; eauto. - InvBooleans. subst m. - destruct (eq_addressing a addr). - inv H; inv H2. eapply ebs_load2_1; eauto. - destruct (option_eq eq_addressing (offset_addressing a 4) (Some addr)). - inv H; inv H2. eapply ebs_load2_2; eauto. - discriminate. - eapply ebs_load; eauto. - inv H. eapply ebs_load_dead; eauto. -- (* store *) - destruct b0; MonadInv. destruct i; MonadInv; UseParsingLemmas. - destruct (chunk_eq m Mint64 && Archi.splitlong) eqn:A; MonadInv; UseParsingLemmas. - destruct b as [ | [] b]; MonadInv; UseParsingLemmas. - InvBooleans. subst m. eapply ebs_store2; eauto. - eapply ebs_store; eauto. -- (* call *) - destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. -- (* tailcall *) - destruct b0 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. -- (* builtin *) - destruct b1 as [|[] ]; MonadInv; UseParsingLemmas. econstructor; eauto. -- (* cond *) - destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. -- (* jumptable *) - destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. -- (* return *) - destruct b0 as [|[]]; MonadInv; UseParsingLemmas. econstructor; eauto. -Qed. - -Lemma matching_instr_block: - forall f1 f2 pc bsh i, - (pair_codes f1 f2)!pc = Some bsh -> - (RTL.fn_code f1)!pc = Some i -> - exists b, (LTL.fn_code f2)!pc = Some b /\ expand_block_shape bsh i b. -Proof. - intros. unfold pair_codes in H. rewrite PTree.gcombine in H; auto. rewrite H0 in H. - destruct (LTL.fn_code f2)!pc as [b|]. - exists b; split; auto. apply pair_instr_block_sound; auto. - discriminate. -Qed. - -(** * Properties of equations *) - -Module ESF := FSetFacts.Facts(EqSet). -Module ESP := FSetProperties.Properties(EqSet). -Module ESD := FSetDecide.Decide(EqSet). - -Definition sel_val (k: equation_kind) (v: val) : val := - match k with - | Full => v - | Low => Val.loword v - | High => Val.hiword v - end. - -(** A set of equations [e] is satisfied in a RTL pseudoreg state [rs] - and an LTL location state [ls] if, for every equation [r = l [k]] in [e], - [sel_val k (rs#r)] (the [k] fragment of [r]'s value in the RTL code) - is less defined than [ls l] (the value of [l] in the LTL code). *) - -Definition satisf (rs: regset) (ls: locset) (e: eqs) : Prop := - forall q, EqSet.In q e -> Val.lessdef (sel_val (ekind q) rs#(ereg q)) (ls (eloc q)). - -Lemma empty_eqs_satisf: - forall rs ls, satisf rs ls empty_eqs. -Proof. - unfold empty_eqs; intros; red; intros. ESD.fsetdec. -Qed. - -Lemma satisf_incr: - forall rs ls (e1 e2: eqs), - satisf rs ls e2 -> EqSet.Subset e1 e2 -> satisf rs ls e1. -Proof. - unfold satisf; intros. apply H. ESD.fsetdec. -Qed. - -Lemma satisf_undef_reg: - forall rs ls e r, - satisf rs ls e -> - satisf (rs#r <- Vundef) ls e. -Proof. - intros; red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r); auto. - destruct (ekind q); simpl; auto. -Qed. - -Lemma add_equation_lessdef: - forall rs ls q e, - satisf rs ls (add_equation q e) -> Val.lessdef (sel_val (ekind q) rs#(ereg q)) (ls (eloc q)). -Proof. - intros. apply H. unfold add_equation. simpl. apply EqSet.add_1. auto. -Qed. - -Lemma add_equation_satisf: - forall rs ls q e, - satisf rs ls (add_equation q e) -> satisf rs ls e. -Proof. - intros. eapply satisf_incr; eauto. unfold add_equation. simpl. ESD.fsetdec. -Qed. - -Lemma add_equations_satisf: - forall rs ls rl ml e e', - add_equations rl ml e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - induction rl; destruct ml; simpl; intros; MonadInv. - auto. - eapply add_equation_satisf; eauto. -Qed. - -Lemma add_equations_lessdef: - forall rs ls rl ml e e', - add_equations rl ml e = Some e' -> - satisf rs ls e' -> - Val.lessdef_list (rs##rl) (reglist ls ml). -Proof. - induction rl; destruct ml; simpl; intros; MonadInv. - constructor. - constructor; eauto. - apply add_equation_lessdef with (e := e) (q := Eq Full a (R m)). - eapply add_equations_satisf; eauto. -Qed. - -Lemma add_equations_args_satisf: - forall rs ls rl tyl ll e e', - add_equations_args rl tyl ll e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - intros until e'. functional induction (add_equations_args rl tyl ll e); intros. -- inv H; auto. -- eapply add_equation_satisf; eauto. -- discriminate. -- eapply add_equation_satisf. eapply add_equation_satisf. eauto. -- congruence. -Qed. - -Lemma val_longofwords_eq_1: - forall v, - Val.has_type v Tlong -> Archi.ptr64 = false -> - Val.longofwords (Val.hiword v) (Val.loword v) = v. -Proof. - intros. red in H. destruct v; try contradiction. -- reflexivity. -- simpl. rewrite Int64.ofwords_recompose. auto. -- congruence. -Qed. - -Lemma val_longofwords_eq_2: - forall v, - Val.has_type v Tlong -> Archi.splitlong = true -> - Val.longofwords (Val.hiword v) (Val.loword v) = v. -Proof. - intros. apply Archi.splitlong_ptr32 in H0. apply val_longofwords_eq_1; assumption. -Qed. - -Lemma add_equations_args_lessdef: - forall rs ls rl tyl ll e e', - add_equations_args rl tyl ll e = Some e' -> - satisf rs ls e' -> - Val.has_type_list (rs##rl) tyl -> - Val.lessdef_list (rs##rl) (map (fun p => Locmap.getpair p ls) ll). -Proof. - intros until e'. functional induction (add_equations_args rl tyl ll e); simpl; intros. -- inv H; auto. -- destruct H1. constructor; auto. - eapply add_equation_lessdef with (q := Eq Full r1 l1). eapply add_equations_args_satisf; eauto. -- discriminate. -- destruct H1. constructor; auto. - rewrite <- (val_longofwords_eq_1 (rs#r1)) by auto. apply Val.longofwords_lessdef. - eapply add_equation_lessdef with (q := Eq High r1 l1). - eapply add_equation_satisf. eapply add_equations_args_satisf; eauto. - eapply add_equation_lessdef with (q := Eq Low r1 l2). - eapply add_equations_args_satisf; eauto. -- discriminate. -Qed. - -Lemma add_equation_ros_satisf: - forall rs ls ros mos e e', - add_equation_ros ros mos e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - unfold add_equation_ros; intros. destruct ros; destruct mos; MonadInv. - eapply add_equation_satisf; eauto. - auto. -Qed. - -Lemma remove_equation_satisf: - forall rs ls q e, - satisf rs ls e -> satisf rs ls (remove_equation q e). -Proof. - intros. eapply satisf_incr; eauto. unfold remove_equation; simpl. ESD.fsetdec. -Qed. - -Lemma remove_equation_res_satisf: - forall rs ls r l e e', - remove_equations_res r l e = Some e' -> - satisf rs ls e -> satisf rs ls e'. -Proof. - intros. functional inversion H. - apply remove_equation_satisf; auto. - apply remove_equation_satisf. apply remove_equation_satisf; auto. -Qed. - -Remark select_reg_l_monotone: - forall r q1 q2, - OrderedEquation.eq q1 q2 \/ OrderedEquation.lt q1 q2 -> - select_reg_l r q1 = true -> select_reg_l r q2 = true. -Proof. - unfold select_reg_l; intros. destruct H. - red in H. congruence. - rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. - red in A. zify; omega. - rewrite <- A; auto. -Qed. - -Remark select_reg_h_monotone: - forall r q1 q2, - OrderedEquation.eq q1 q2 \/ OrderedEquation.lt q2 q1 -> - select_reg_h r q1 = true -> select_reg_h r q2 = true. -Proof. - unfold select_reg_h; intros. destruct H. - red in H. congruence. - rewrite Pos.leb_le in *. red in H. destruct H as [A | [A B]]. - red in A. zify; omega. - rewrite A; auto. -Qed. - -Remark select_reg_charact: - forall r q, select_reg_l r q = true /\ select_reg_h r q = true <-> ereg q = r. -Proof. - unfold select_reg_l, select_reg_h; intros; split. - rewrite ! Pos.leb_le. unfold reg; zify; omega. - intros. rewrite H. rewrite ! Pos.leb_refl; auto. -Qed. - -Lemma reg_unconstrained_sound: - forall r e q, - reg_unconstrained r e = true -> - EqSet.In q e -> - ereg q <> r. -Proof. - unfold reg_unconstrained; intros. red; intros. - apply select_reg_charact in H1. - assert (EqSet.mem_between (select_reg_l r) (select_reg_h r) e = true). - { - apply EqSet.mem_between_2 with q; auto. - exact (select_reg_l_monotone r). - exact (select_reg_h_monotone r). - tauto. - tauto. - } - rewrite H2 in H; discriminate. -Qed. - -Lemma reg_unconstrained_satisf: - forall r e rs ls v, - reg_unconstrained r e = true -> - satisf rs ls e -> - satisf (rs#r <- v) ls e. -Proof. - red; intros. rewrite PMap.gso. auto. eapply reg_unconstrained_sound; eauto. -Qed. - -Remark select_loc_l_monotone: - forall l q1 q2, - OrderedEquation'.eq q1 q2 \/ OrderedEquation'.lt q1 q2 -> - select_loc_l l q1 = true -> select_loc_l l q2 = true. -Proof. - unfold select_loc_l; intros. set (lb := OrderedLoc.diff_low_bound l) in *. - destruct H. - red in H. subst q2; auto. - assert (eloc q1 = eloc q2 \/ OrderedLoc.lt (eloc q1) (eloc q2)). - red in H. tauto. - destruct H1. rewrite <- H1; auto. - destruct (OrderedLoc.compare (eloc q2) lb); auto. - assert (OrderedLoc.lt (eloc q1) lb) by (eapply OrderedLoc.lt_trans; eauto). - destruct (OrderedLoc.compare (eloc q1) lb). - auto. - eelim OrderedLoc.lt_not_eq; eauto. - eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans. eexact l1. eexact H2. red; auto. -Qed. - -Remark select_loc_h_monotone: - forall l q1 q2, - OrderedEquation'.eq q1 q2 \/ OrderedEquation'.lt q2 q1 -> - select_loc_h l q1 = true -> select_loc_h l q2 = true. -Proof. - unfold select_loc_h; intros. set (lb := OrderedLoc.diff_high_bound l) in *. - destruct H. - red in H. subst q2; auto. - assert (eloc q2 = eloc q1 \/ OrderedLoc.lt (eloc q2) (eloc q1)). - red in H. tauto. - destruct H1. rewrite H1; auto. - destruct (OrderedLoc.compare (eloc q2) lb); auto. - assert (OrderedLoc.lt lb (eloc q1)) by (eapply OrderedLoc.lt_trans; eauto). - destruct (OrderedLoc.compare (eloc q1) lb). - eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans. eexact l1. eexact H2. red; auto. - eelim OrderedLoc.lt_not_eq. eexact H2. apply OrderedLoc.eq_sym; auto. - auto. -Qed. - -Remark select_loc_charact: - forall l q, - select_loc_l l q = false \/ select_loc_h l q = false <-> Loc.diff l (eloc q). -Proof. - unfold select_loc_l, select_loc_h; intros; split; intros. - apply OrderedLoc.outside_interval_diff. - destruct H. - left. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_low_bound l)); assumption || discriminate. - right. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_high_bound l)); assumption || discriminate. - exploit OrderedLoc.diff_outside_interval. eauto. - intros [A | A]. - left. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_low_bound l)). - auto. - eelim OrderedLoc.lt_not_eq; eauto. - eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans; eauto. red; auto. - right. destruct (OrderedLoc.compare (eloc q) (OrderedLoc.diff_high_bound l)). - eelim OrderedLoc.lt_not_eq. eapply OrderedLoc.lt_trans; eauto. red; auto. - eelim OrderedLoc.lt_not_eq; eauto. apply OrderedLoc.eq_sym; auto. - auto. -Qed. - -Lemma loc_unconstrained_sound: - forall l e q, - loc_unconstrained l e = true -> - EqSet.In q e -> - Loc.diff l (eloc q). -Proof. - unfold loc_unconstrained; intros. - destruct (select_loc_l l q) eqn:SL. - destruct (select_loc_h l q) eqn:SH. - assert (EqSet2.mem_between (select_loc_l l) (select_loc_h l) (eqs2 e) = true). - { - apply EqSet2.mem_between_2 with q; auto. - exact (select_loc_l_monotone l). - exact (select_loc_h_monotone l). - apply eqs_same. auto. - } - rewrite H1 in H; discriminate. - apply select_loc_charact; auto. - apply select_loc_charact; auto. -Qed. - -Lemma loc_unconstrained_satisf: - forall rs ls k r mr e v, - let l := R mr in - satisf rs ls (remove_equation (Eq k r l) e) -> - loc_unconstrained (R mr) (remove_equation (Eq k r l) e) = true -> - Val.lessdef (sel_val k rs#r) v -> - satisf rs (Locmap.set l v ls) e. -Proof. - intros; red; intros. - destruct (OrderedEquation.eq_dec q (Eq k r l)). - subst q; simpl. unfold l; rewrite Locmap.gss. auto. - assert (EqSet.In q (remove_equation (Eq k r l) e)). - simpl. ESD.fsetdec. - rewrite Locmap.gso. apply H; auto. eapply loc_unconstrained_sound; eauto. -Qed. - -Lemma reg_loc_unconstrained_sound: - forall r l e q, - reg_loc_unconstrained r l e = true -> - EqSet.In q e -> - ereg q <> r /\ Loc.diff l (eloc q). -Proof. - intros. destruct (andb_prop _ _ H). - split. eapply reg_unconstrained_sound; eauto. eapply loc_unconstrained_sound; eauto. -Qed. - -Lemma parallel_assignment_satisf: - forall k r mr e rs ls v v', - let l := R mr in - Val.lessdef (sel_val k v) v' -> - reg_loc_unconstrained r (R mr) (remove_equation (Eq k r l) e) = true -> - satisf rs ls (remove_equation (Eq k r l) e) -> - satisf (rs#r <- v) (Locmap.set l v' ls) e. -Proof. - intros; red; intros. - destruct (OrderedEquation.eq_dec q (Eq k r l)). - subst q; simpl. unfold l; rewrite Regmap.gss; rewrite Locmap.gss; auto. - assert (EqSet.In q (remove_equation {| ekind := k; ereg := r; eloc := l |} e)). - simpl. ESD.fsetdec. - exploit reg_loc_unconstrained_sound; eauto. intros [A B]. - rewrite Regmap.gso; auto. rewrite Locmap.gso; auto. -Qed. - -Lemma parallel_assignment_satisf_2: - forall rs ls res res' e e' v v', - remove_equations_res res res' e = Some e' -> - satisf rs ls e' -> - reg_unconstrained res e' = true -> - forallb (fun l => loc_unconstrained l e') (map R (regs_of_rpair res')) = true -> - Val.lessdef v v' -> - satisf (rs#res <- v) (Locmap.setpair res' v' ls) e. -Proof. - intros. functional inversion H. -- (* One location *) - subst. simpl in H2. InvBooleans. simpl. - apply parallel_assignment_satisf with Full; auto. - unfold reg_loc_unconstrained. rewrite H1, H4. auto. -- (* Two 32-bit halves *) - subst. - set (e' := remove_equation {| ekind := Low; ereg := res; eloc := R mr2 |} - (remove_equation {| ekind := High; ereg := res; eloc := R mr1 |} e)) in *. - simpl in H2. InvBooleans. simpl. - red; intros. - destruct (OrderedEquation.eq_dec q (Eq Low res (R mr2))). - subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gss. - apply Val.loword_lessdef; auto. - destruct (OrderedEquation.eq_dec q (Eq High res (R mr1))). - subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gso by auto. rewrite Locmap.gss. - apply Val.hiword_lessdef; auto. - assert (EqSet.In q e'). unfold e', remove_equation; simpl; ESD.fsetdec. - rewrite Regmap.gso. rewrite ! Locmap.gso. auto. - eapply loc_unconstrained_sound; eauto. - eapply loc_unconstrained_sound; eauto. - eapply reg_unconstrained_sound; eauto. -Qed. - -Remark in_elements_between_1: - forall r1 s q, - EqSet.In q (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) s) <-> EqSet.In q s /\ ereg q = r1. -Proof. - intros. rewrite EqSet.elements_between_iff, select_reg_charact. tauto. - exact (select_reg_l_monotone r1). exact (select_reg_h_monotone r1). -Qed. - -Lemma in_subst_reg: - forall r1 r2 q (e: eqs), - EqSet.In q e -> - ereg q = r1 /\ EqSet.In (Eq (ekind q) r2 (eloc q)) (subst_reg r1 r2 e) - \/ ereg q <> r1 /\ EqSet.In q (subst_reg r1 r2 e). -Proof. - intros r1 r2 q e0 IN0. unfold subst_reg. - set (f := fun (q: EqSet.elt) e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e)). - generalize (in_elements_between_1 r1 e0). - set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). - intros IN_ELT. - set (P := fun e1 e2 => - EqSet.In q e1 -> - EqSet.In (Eq (ekind q) r2 (eloc q)) e2). - assert (P elt (EqSet.fold f elt e0)). - { - apply ESP.fold_rec; unfold P; intros. - - ESD.fsetdec. - - simpl. red in H1. apply H1 in H3. destruct H3. - + subst x. ESD.fsetdec. - + rewrite ESF.add_iff. rewrite ESF.remove_iff. - destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := r2; eloc := eloc q |}); auto. - left. subst x; auto. - } - set (Q := fun e1 e2 => - ~EqSet.In q e1 -> - EqSet.In q e2). - assert (Q elt (EqSet.fold f elt e0)). - { - apply ESP.fold_rec; unfold Q; intros. - - auto. - - simpl. red in H2. rewrite H2 in H4. ESD.fsetdec. - } - destruct (ESP.In_dec q elt). - left. split. apply IN_ELT. auto. apply H. auto. - right. split. red; intros. elim n. rewrite IN_ELT. auto. apply H0. auto. -Qed. - -Lemma subst_reg_satisf: - forall src dst rs ls e, - satisf rs ls (subst_reg dst src e) -> - satisf (rs#dst <- (rs#src)) ls e. -Proof. - intros; red; intros. - destruct (in_subst_reg dst src q e H0) as [[A B] | [A B]]. - subst dst. rewrite Regmap.gss. exploit H; eauto. - rewrite Regmap.gso; auto. -Qed. - -Lemma in_subst_reg_kind: - forall r1 k1 r2 k2 q (e: eqs), - EqSet.In q e -> - (ereg q, ekind q) = (r1, k1) /\ EqSet.In (Eq k2 r2 (eloc q)) (subst_reg_kind r1 k1 r2 k2 e) - \/ EqSet.In q (subst_reg_kind r1 k1 r2 k2 e). -Proof. - intros r1 k1 r2 k2 q e0 IN0. unfold subst_reg. - set (f := fun (q: EqSet.elt) e => - if IndexedEqKind.eq (ekind q) k1 - then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e) - else e). - generalize (in_elements_between_1 r1 e0). - set (elt := EqSet.elements_between (select_reg_l r1) (select_reg_h r1) e0). - intros IN_ELT. - set (P := fun e1 e2 => - EqSet.In q e1 -> ekind q = k1 -> - EqSet.In (Eq k2 r2 (eloc q)) e2). - assert (P elt (EqSet.fold f elt e0)). - { - intros; apply ESP.fold_rec; unfold P; intros. - - ESD.fsetdec. - - simpl. red in H1. apply H1 in H3. destruct H3. - + subst x. unfold f. destruct (IndexedEqKind.eq (ekind q) k1). - simpl. ESD.fsetdec. contradiction. - + unfold f. destruct (IndexedEqKind.eq (ekind x) k1). - simpl. rewrite ESF.add_iff. rewrite ESF.remove_iff. - destruct (OrderedEquation.eq_dec x {| ekind := k2; ereg := r2; eloc := eloc q |}); auto. - left. subst x; auto. - auto. - } - set (Q := fun e1 e2 => - ~EqSet.In q e1 \/ ekind q <> k1 -> - EqSet.In q e2). - assert (Q elt (EqSet.fold f elt e0)). - { - apply ESP.fold_rec; unfold Q; intros. - - auto. - - unfold f. red in H2. rewrite H2 in H4. - destruct (IndexedEqKind.eq (ekind x) k1). - simpl. rewrite ESF.add_iff. rewrite ESF.remove_iff. - right. split. apply H3. tauto. intuition congruence. - apply H3. intuition auto. - } - destruct (ESP.In_dec q elt). - destruct (IndexedEqKind.eq (ekind q) k1). - left. split. f_equal. apply IN_ELT. auto. auto. apply H. auto. auto. - right. apply H0. auto. - right. apply H0. auto. -Qed. - -Lemma subst_reg_kind_satisf_makelong: - forall src1 src2 dst rs ls e, - let e1 := subst_reg_kind dst High src1 Full e in - let e2 := subst_reg_kind dst Low src2 Full e1 in - reg_unconstrained dst e2 = true -> - satisf rs ls e2 -> - satisf (rs#dst <- (Val.longofwords rs#src1 rs#src2)) ls e. -Proof. - intros; red; intros. - destruct (in_subst_reg_kind dst High src1 Full q e H1) as [[A B] | B]; fold e1 in B. - destruct (in_subst_reg_kind dst Low src2 Full _ e1 B) as [[C D] | D]; fold e2 in D. - simpl in C; simpl in D. inv C. - inversion A. rewrite H3; rewrite H4. rewrite Regmap.gss. - apply Val.lessdef_trans with (rs#src1). - simpl. destruct (rs#src1); simpl; auto. destruct (rs#src2); simpl; auto. - rewrite Int64.hi_ofwords. auto. - exploit H0. eexact D. simpl. auto. - destruct (in_subst_reg_kind dst Low src2 Full q e1 B) as [[C D] | D]; fold e2 in D. - inversion C. rewrite H3; rewrite H4. rewrite Regmap.gss. - apply Val.lessdef_trans with (rs#src2). - simpl. destruct (rs#src1); simpl; auto. destruct (rs#src2); simpl; auto. - rewrite Int64.lo_ofwords. auto. - exploit H0. eexact D. simpl. auto. - rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. -Qed. - -Lemma subst_reg_kind_satisf_lowlong: - forall src dst rs ls e, - let e1 := subst_reg_kind dst Full src Low e in - reg_unconstrained dst e1 = true -> - satisf rs ls e1 -> - satisf (rs#dst <- (Val.loword rs#src)) ls e. -Proof. - intros; red; intros. - destruct (in_subst_reg_kind dst Full src Low q e H1) as [[A B] | B]; fold e1 in B. - inversion A. rewrite H3; rewrite H4. simpl. rewrite Regmap.gss. - exploit H0. eexact B. simpl. auto. - rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. -Qed. - -Lemma subst_reg_kind_satisf_highlong: - forall src dst rs ls e, - let e1 := subst_reg_kind dst Full src High e in - reg_unconstrained dst e1 = true -> - satisf rs ls e1 -> - satisf (rs#dst <- (Val.hiword rs#src)) ls e. -Proof. - intros; red; intros. - destruct (in_subst_reg_kind dst Full src High q e H1) as [[A B] | B]; fold e1 in B. - inversion A. rewrite H3; rewrite H4. simpl. rewrite Regmap.gss. - exploit H0. eexact B. simpl. auto. - rewrite Regmap.gso. apply H0; auto. eapply reg_unconstrained_sound; eauto. -Qed. - -Module ESF2 := FSetFacts.Facts(EqSet2). -Module ESP2 := FSetProperties.Properties(EqSet2). -Module ESD2 := FSetDecide.Decide(EqSet2). - -Lemma partial_fold_ind: - forall (A: Type) (P: EqSet2.t -> A -> Prop) f init final s, - EqSet2.fold - (fun q opte => - match opte with - | None => None - | Some e => f q e - end) - s (Some init) = Some final -> - (forall s', EqSet2.Empty s' -> P s' init) -> - (forall x a' a'' s' s'', - EqSet2.In x s -> ~EqSet2.In x s' -> ESP2.Add x s' s'' -> - f x a' = Some a'' -> P s' a' -> P s'' a'') -> - P s final. -Proof. - intros. - set (g := fun q opte => match opte with Some e => f q e | None => None end) in *. - set (Q := fun s1 opte => match opte with None => True | Some e => P s1 e end). - change (Q s (Some final)). - rewrite <- H. apply ESP2.fold_rec; unfold Q, g; intros. - - auto. - - destruct a as [e|]; auto. destruct (f x e) as [e'|] eqn:F; auto. eapply H1; eauto. -Qed. - -Lemma in_subst_loc: - forall l1 l2 q (e e': eqs), - EqSet.In q e -> - subst_loc l1 l2 e = Some e' -> - (eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e') \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). -Proof. - unfold subst_loc; intros l1 l2 q e0 e0' IN SUBST. - set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. - set (f := fun q0 e => - if Loc.eq l1 (eloc q0) then - Some (add_equation - {| ekind := ekind q0; ereg := ereg q0; eloc := l2 |} - (remove_equation q0 e)) - else None). - set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ EqSet.In (Eq (ekind q) (ereg q) l2) e2). - assert (A: P elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold P; intros. ESD2.fsetdec. - - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. - simpl. rewrite ESF.add_iff, ESF.remove_iff. - apply H1 in H4; destruct H4. - subst x; rewrite e; auto. - apply H3 in H2; destruct H2. split. congruence. - destruct (OrderedEquation.eq_dec x {| ekind := ekind q; ereg := ereg q; eloc := l2 |}); auto. - subst x; auto. - } - set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). - assert (B: Q elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold Q; intros. auto. - - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); inversion H2; subst a''; clear H2. - simpl. rewrite ESF.add_iff, ESF.remove_iff. - red in H1. rewrite H1 in H4. intuition auto. } - destruct (ESP2.In_dec q elt). - left. apply A; auto. - right. split; auto. - rewrite <- select_loc_charact. - destruct (select_loc_l l1 q) eqn: LL; auto. - destruct (select_loc_h l1 q) eqn: LH; auto. - elim n. eapply EqSet2.elements_between_iff. - exact (select_loc_l_monotone l1). - exact (select_loc_h_monotone l1). - split. apply eqs_same; auto. auto. -Qed. - -Lemma loc_type_compat_charact: - forall env l e q, - loc_type_compat env l e = true -> - EqSet.In q e -> - subtype (sel_type (ekind q) (env (ereg q))) (Loc.type l) = true \/ Loc.diff l (eloc q). -Proof. - unfold loc_type_compat; intros. - rewrite EqSet2.for_all_between_iff in H. - destruct (select_loc_l l q) eqn: LL. - destruct (select_loc_h l q) eqn: LH. - left; apply H; auto. apply eqs_same; auto. - right. apply select_loc_charact. auto. - right. apply select_loc_charact. auto. - intros; subst; auto. - exact (select_loc_l_monotone l). - exact (select_loc_h_monotone l). -Qed. - -Lemma well_typed_move_charact: - forall env l e k r rs, - well_typed_move env l e = true -> - EqSet.In (Eq k r l) e -> - wt_regset env rs -> - match l with - | R mr => True - | S sl ofs ty => Val.has_type (sel_val k rs#r) ty - end. -Proof. - unfold well_typed_move; intros. - destruct l as [mr | sl ofs ty]. - auto. - exploit loc_type_compat_charact; eauto. intros [A | A]. - simpl in A. eapply Val.has_subtype; eauto. - generalize (H1 r). destruct k; simpl; intros. - auto. - destruct (rs#r); exact I. - destruct (rs#r); exact I. - eelim Loc.diff_not_eq. eexact A. auto. -Qed. - -Remark val_lessdef_normalize: - forall v v' ty, - Val.has_type v ty -> Val.lessdef v v' -> - Val.lessdef v (Val.load_result (chunk_of_type ty) v'). -Proof. - intros. inv H0. rewrite Val.load_result_same; auto. auto. -Qed. - -Lemma subst_loc_satisf: - forall env src dst rs ls e e', - subst_loc dst src e = Some e' -> - well_typed_move env dst e = true -> - wt_regset env rs -> - satisf rs ls e' -> - satisf rs (Locmap.set dst (ls src) ls) e. -Proof. - intros; red; intros. - exploit in_subst_loc; eauto. intros [[A B] | [A B]]. - subst dst. rewrite Locmap.gss. - destruct q as [k r l]; simpl in *. - exploit well_typed_move_charact; eauto. - destruct l as [mr | sl ofs ty]; intros. - apply (H2 _ B). - apply val_lessdef_normalize; auto. apply (H2 _ B). - rewrite Locmap.gso; auto. -Qed. - -Lemma in_subst_loc_part: - forall l1 l2 k q (e e': eqs), - EqSet.In q e -> - subst_loc_part l1 l2 k e = Some e' -> - (eloc q = l1 /\ ekind q = k /\ EqSet.In (Eq Full (ereg q) l2) e') \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). -Proof. - unfold subst_loc_part; intros l1 l2 k q e0 e0' IN SUBST. - set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. - set (f := fun q0 e => - if Loc.eq l1 (eloc q0) then - if IndexedEqKind.eq (ekind q0) k then - Some (add_equation - {| ekind := Full; ereg := ereg q0; eloc := l2 |} - (remove_equation q0 e)) - else None else None). - set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ ekind q = k /\ EqSet.In (Eq Full (ereg q) l2) e2). - assert (A: P elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold P; intros. ESD2.fsetdec. - - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); try discriminate. - destruct (IndexedEqKind.eq (ekind x) k); inversion H2; subst a''; clear H2. - simpl. rewrite ESF.add_iff, ESF.remove_iff. - apply H1 in H4; destruct H4. - subst x; rewrite e, <- e1; auto. - apply H3 in H2; destruct H2 as (X & Y & Z). split; auto. split; auto. - destruct (OrderedEquation.eq_dec x {| ekind := Full; ereg := ereg q; eloc := l2 |}); auto. - subst x; auto. - } - set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). - assert (B: Q elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold Q; intros. auto. - - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); try congruence. - destruct (IndexedEqKind.eq (ekind x) k); inversion H2; subst a''; clear H2. - simpl. rewrite ESF.add_iff, ESF.remove_iff. - red in H1. rewrite H1 in H4. intuition auto. } - destruct (ESP2.In_dec q elt). - left. apply A; auto. - right. split; auto. - rewrite <- select_loc_charact. - destruct (select_loc_l l1 q) eqn: LL; auto. - destruct (select_loc_h l1 q) eqn: LH; auto. - elim n. eapply EqSet2.elements_between_iff. - exact (select_loc_l_monotone l1). - exact (select_loc_h_monotone l1). - split. apply eqs_same; auto. auto. -Qed. - -Lemma subst_loc_part_satisf_lowlong: - forall src dst rs ls e e', - subst_loc_part (R dst) (R src) Low e = Some e' -> - satisf rs ls e' -> - satisf rs (Locmap.set (R dst) (Val.loword (ls (R src))) ls) e. -Proof. - intros; red; intros. - exploit in_subst_loc_part; eauto. intros [[A [B C]] | [A B]]. - rewrite A, B. apply H0 in C. rewrite Locmap.gss. apply Val.loword_lessdef. exact C. - rewrite Locmap.gso; auto. -Qed. - -Lemma subst_loc_part_satisf_highlong: - forall src dst rs ls e e', - subst_loc_part (R dst) (R src) High e = Some e' -> - satisf rs ls e' -> - satisf rs (Locmap.set (R dst) (Val.hiword (ls (R src))) ls) e. -Proof. - intros; red; intros. - exploit in_subst_loc_part; eauto. intros [[A [B C]] | [A B]]. - rewrite A, B. apply H0 in C. rewrite Locmap.gss. apply Val.hiword_lessdef. exact C. - rewrite Locmap.gso; auto. -Qed. - -Lemma in_subst_loc_pair: - forall l1 l2 l2' q (e e': eqs), - EqSet.In q e -> - subst_loc_pair l1 l2 l2' e = Some e' -> - (eloc q = l1 /\ ekind q = Full /\ EqSet.In (Eq High (ereg q) l2) e' /\ EqSet.In (Eq Low (ereg q) l2') e') - \/ (Loc.diff l1 (eloc q) /\ EqSet.In q e'). -Proof. - unfold subst_loc_pair; intros l1 l2 l2' q e0 e0' IN SUBST. - set (elt := EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e0)) in *. - set (f := fun q0 e => - if Loc.eq l1 (eloc q0) then - if IndexedEqKind.eq (ekind q0) Full then - Some (add_equation {| ekind := High; ereg := ereg q0; eloc := l2 |} - (add_equation {| ekind := Low; ereg := ereg q0; eloc := l2' |} - (remove_equation q0 e))) - else None else None). - set (P := fun e1 e2 => EqSet2.In q e1 -> eloc q = l1 /\ ekind q = Full - /\ EqSet.In (Eq High (ereg q) l2) e2 - /\ EqSet.In (Eq Low (ereg q) l2') e2). - assert (A: P elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold P; intros. ESD2.fsetdec. - - unfold P, f; intros. destruct (Loc.eq l1 (eloc x)); try discriminate. - destruct (IndexedEqKind.eq (ekind x) Full); inversion H2; subst a''; clear H2. - simpl. rewrite ! ESF.add_iff, ! ESF.remove_iff. - apply H1 in H4; destruct H4. - subst x. rewrite e, e1. intuition auto. - apply H3 in H2; destruct H2 as (U & V & W & X). - destruct (OrderedEquation.eq_dec x {| ekind := High; ereg := ereg q; eloc := l2 |}). - subst x. intuition auto. - destruct (OrderedEquation.eq_dec x {| ekind := Low; ereg := ereg q; eloc := l2' |}). - subst x. intuition auto. - intuition auto. } - set (Q := fun e1 e2 => ~EqSet2.In q e1 -> EqSet.In q e2). - assert (B: Q elt e0'). - { eapply partial_fold_ind with (f := f) (s := elt) (final := e0'). eexact SUBST. - - unfold Q; intros. auto. - - unfold Q, f; intros. destruct (Loc.eq l1 (eloc x)); try congruence. - destruct (IndexedEqKind.eq (ekind x) Full); inversion H2; subst a''; clear H2. - simpl. rewrite ! ESF.add_iff, ! ESF.remove_iff. - red in H1. rewrite H1 in H4. intuition auto. } - destruct (ESP2.In_dec q elt). - left. apply A; auto. - right. split; auto. - rewrite <- select_loc_charact. - destruct (select_loc_l l1 q) eqn: LL; auto. - destruct (select_loc_h l1 q) eqn: LH; auto. - elim n. eapply EqSet2.elements_between_iff. - exact (select_loc_l_monotone l1). - exact (select_loc_h_monotone l1). - split. apply eqs_same; auto. auto. -Qed. - -Lemma long_type_compat_charact: - forall env l e q, - long_type_compat env l e = true -> - EqSet.In q e -> - subtype (env (ereg q)) Tlong = true \/ Loc.diff l (eloc q). -Proof. - unfold long_type_compat; intros. - rewrite EqSet2.for_all_between_iff in H. - destruct (select_loc_l l q) eqn: LL. - destruct (select_loc_h l q) eqn: LH. - left; apply H; auto. apply eqs_same; auto. - right. apply select_loc_charact. auto. - right. apply select_loc_charact. auto. - intros; subst; auto. - exact (select_loc_l_monotone l). - exact (select_loc_h_monotone l). -Qed. - -Lemma subst_loc_pair_satisf_makelong: - forall env src1 src2 dst rs ls e e', - subst_loc_pair (R dst) (R src1) (R src2) e = Some e' -> - long_type_compat env (R dst) e = true -> - wt_regset env rs -> - satisf rs ls e' -> - Archi.ptr64 = false -> - satisf rs (Locmap.set (R dst) (Val.longofwords (ls (R src1)) (ls (R src2))) ls) e. -Proof. - intros; red; intros. - exploit in_subst_loc_pair; eauto. intros [[A [B [C D]]] | [A B]]. -- rewrite A, B. apply H2 in C. apply H2 in D. - assert (subtype (env (ereg q)) Tlong = true). - { exploit long_type_compat_charact; eauto. intros [P|P]; auto. - eelim Loc.diff_not_eq; eauto. } - rewrite Locmap.gss. simpl. rewrite <- (val_longofwords_eq_1 rs#(ereg q)). - apply Val.longofwords_lessdef. exact C. exact D. - eapply Val.has_subtype; eauto. - assumption. -- rewrite Locmap.gso; auto. -Qed. - -Lemma can_undef_sound: - forall e ml q, - can_undef ml e = true -> EqSet.In q e -> Loc.notin (eloc q) (map R ml). -Proof. - induction ml; simpl; intros. - tauto. - InvBooleans. split. - apply Loc.diff_sym. eapply loc_unconstrained_sound; eauto. - eauto. -Qed. - -Lemma undef_regs_outside: - forall ml ls l, - Loc.notin l (map R ml) -> undef_regs ml ls l = ls l. -Proof. - induction ml; simpl; intros. auto. - rewrite Locmap.gso. apply IHml. tauto. apply Loc.diff_sym. tauto. -Qed. - -Lemma can_undef_satisf: - forall ml e rs ls, - can_undef ml e = true -> - satisf rs ls e -> - satisf rs (undef_regs ml ls) e. -Proof. - intros; red; intros. rewrite undef_regs_outside. eauto. - eapply can_undef_sound; eauto. -Qed. - -Lemma can_undef_except_sound: - forall lx e ml q, - can_undef_except lx ml e = true -> EqSet.In q e -> Loc.diff (eloc q) lx -> Loc.notin (eloc q) (map R ml). -Proof. - induction ml; simpl; intros. - tauto. - InvBooleans. split. - destruct (orb_true_elim _ _ H2). - apply proj_sumbool_true in e0. congruence. - apply Loc.diff_sym. eapply loc_unconstrained_sound; eauto. - eapply IHml; eauto. -Qed. - -Lemma subst_loc_undef_satisf: - forall env src dst rs ls ml e e', - subst_loc dst src e = Some e' -> - well_typed_move env dst e = true -> - can_undef_except dst ml e = true -> - wt_regset env rs -> - satisf rs ls e' -> - satisf rs (Locmap.set dst (ls src) (undef_regs ml ls)) e. -Proof. - intros; red; intros. - exploit in_subst_loc; eauto. intros [[A B] | [A B]]. - subst dst. rewrite Locmap.gss. - destruct q as [k r l]; simpl in *. - exploit well_typed_move_charact; eauto. - destruct l as [mr | sl ofs ty]; intros. - apply (H3 _ B). - apply val_lessdef_normalize; auto. apply (H3 _ B). - rewrite Locmap.gso; auto. rewrite undef_regs_outside. eauto. - eapply can_undef_except_sound; eauto. apply Loc.diff_sym; auto. -Qed. - -Lemma transfer_use_def_satisf: - forall args res args' res' und e e' rs ls, - transfer_use_def args res args' res' und e = Some e' -> - satisf rs ls e' -> - Val.lessdef_list rs##args (reglist ls args') /\ - (forall v v', Val.lessdef v v' -> - satisf (rs#res <- v) (Locmap.set (R res') v' (undef_regs und ls)) e). -Proof. - unfold transfer_use_def; intros. MonadInv. - split. eapply add_equations_lessdef; eauto. - intros. eapply parallel_assignment_satisf; eauto. assumption. - eapply can_undef_satisf; eauto. - eapply add_equations_satisf; eauto. -Qed. - -Lemma add_equations_res_lessdef: - forall r ty l e e' rs ls, - add_equations_res r ty l e = Some e' -> - satisf rs ls e' -> - Val.has_type rs#r ty -> - Val.lessdef rs#r (Locmap.getpair (map_rpair R l) ls). -Proof. - intros. functional inversion H; simpl. -- subst. eapply add_equation_lessdef with (q := Eq Full r (R mr)); eauto. -- subst. rewrite <- (val_longofwords_eq_1 rs#r) by auto. - apply Val.longofwords_lessdef. - eapply add_equation_lessdef with (q := Eq High r (R mr1)). - eapply add_equation_satisf. eauto. - eapply add_equation_lessdef with (q := Eq Low r (R mr2)). - eauto. -Qed. - -Lemma return_regs_agree_callee_save: - forall caller callee, - agree_callee_save caller (return_regs caller callee). -Proof. - intros; red; intros. unfold return_regs. red in H. - destruct l. - rewrite H; auto. - destruct sl; auto || congruence. -Qed. - -Lemma no_caller_saves_sound: - forall e q, - no_caller_saves e = true -> - EqSet.In q e -> - callee_save_loc (eloc q). -Proof. - unfold no_caller_saves, callee_save_loc; intros. - exploit EqSet.for_all_2; eauto. - hnf. intros. simpl in H1. rewrite H1. auto. - lazy beta. destruct (eloc q). auto. destruct sl; congruence. -Qed. - -Lemma val_hiword_longofwords: - forall v1 v2, Val.lessdef (Val.hiword (Val.longofwords v1 v2)) v1. -Proof. - intros. destruct v1; simpl; auto. destruct v2; auto. unfold Val.hiword. - rewrite Int64.hi_ofwords. auto. -Qed. - -Lemma val_loword_longofwords: - forall v1 v2, Val.lessdef (Val.loword (Val.longofwords v1 v2)) v2. -Proof. - intros. destruct v1; simpl; auto. destruct v2; auto. unfold Val.loword. - rewrite Int64.lo_ofwords. auto. -Qed. - -Lemma function_return_satisf: - forall rs ls_before ls_after res res' sg e e' v, - res' = loc_result sg -> - remove_equations_res res res' e = Some e' -> - satisf rs ls_before e' -> - forallb (fun l => reg_loc_unconstrained res l e') (map R (regs_of_rpair res')) = true -> - no_caller_saves e' = true -> - Val.lessdef v (Locmap.getpair (map_rpair R res') ls_after) -> - agree_callee_save ls_before ls_after -> - satisf (rs#res <- v) ls_after e. -Proof. - intros; red; intros. - functional inversion H0. -- (* One register *) - subst. rewrite <- H8 in *. simpl in *. InvBooleans. - set (e' := remove_equation {| ekind := Full; ereg := res; eloc := R mr |} e) in *. - destruct (OrderedEquation.eq_dec q (Eq Full res (R mr))). - subst q; simpl. rewrite Regmap.gss; auto. - assert (EqSet.In q e'). unfold e', remove_equation; simpl. ESD.fsetdec. - exploit reg_loc_unconstrained_sound; eauto. intros [A B]. - rewrite Regmap.gso; auto. - exploit no_caller_saves_sound; eauto. intros. - red in H5. rewrite <- H5; auto. -- (* Two 32-bit halves *) - subst. rewrite <- H9 in *. simpl in *. - set (e' := remove_equation {| ekind := Low; ereg := res; eloc := R mr2 |} - (remove_equation {| ekind := High; ereg := res; eloc := R mr1 |} e)) in *. - InvBooleans. - destruct (OrderedEquation.eq_dec q (Eq Low res (R mr2))). - subst q; simpl. rewrite Regmap.gss. - eapply Val.lessdef_trans. apply Val.loword_lessdef. eauto. apply val_loword_longofwords. - destruct (OrderedEquation.eq_dec q (Eq High res (R mr1))). - subst q; simpl. rewrite Regmap.gss. - eapply Val.lessdef_trans. apply Val.hiword_lessdef. eauto. apply val_hiword_longofwords. - assert (EqSet.In q e'). unfold e', remove_equation; simpl; ESD.fsetdec. - exploit reg_loc_unconstrained_sound. eexact H. eauto. intros [A B]. - exploit reg_loc_unconstrained_sound. eexact H2. eauto. intros [C D]. - rewrite Regmap.gso; auto. - exploit no_caller_saves_sound; eauto. intros. - red in H5. rewrite <- H5; auto. -Qed. - -Lemma compat_left_sound: - forall r l e q, - compat_left r l e = true -> EqSet.In q e -> ereg q = r -> ekind q = Full /\ eloc q = l. -Proof. - unfold compat_left; intros. - rewrite EqSet.for_all_between_iff in H. - apply select_reg_charact in H1. destruct H1. - exploit H; eauto. intros. - destruct (ekind q); try discriminate. - destruct (Loc.eq l (eloc q)); try discriminate. - auto. - intros. subst x2. auto. - exact (select_reg_l_monotone r). - exact (select_reg_h_monotone r). -Qed. - -Lemma compat_left2_sound: - forall r l1 l2 e q, - compat_left2 r l1 l2 e = true -> EqSet.In q e -> ereg q = r -> - (ekind q = High /\ eloc q = l1) \/ (ekind q = Low /\ eloc q = l2). -Proof. - unfold compat_left2; intros. - rewrite EqSet.for_all_between_iff in H. - apply select_reg_charact in H1. destruct H1. - exploit H; eauto. intros. - destruct (ekind q); try discriminate. - InvBooleans. auto. - InvBooleans. auto. - intros. subst x2. auto. - exact (select_reg_l_monotone r). - exact (select_reg_h_monotone r). -Qed. - -Lemma compat_entry_satisf: - forall rl ll e, - compat_entry rl ll e = true -> - forall vl ls, - Val.lessdef_list vl (map (fun p => Locmap.getpair p ls) ll) -> - satisf (init_regs vl rl) ls e. -Proof. - intros until e. functional induction (compat_entry rl ll e); intros. -- (* no params *) - simpl. red; intros. rewrite Regmap.gi. destruct (ekind q); simpl; auto. -- (* a param in a single location *) - InvBooleans. simpl in H0. inv H0. simpl. - red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r1). - exploit compat_left_sound; eauto. intros [A B]. rewrite A; rewrite B; auto. - eapply IHb; eauto. -- (* a param split across two locations *) - InvBooleans. simpl in H0. inv H0. simpl. - red; intros. rewrite Regmap.gsspec. destruct (peq (ereg q) r1). - exploit compat_left2_sound; eauto. - intros [[A B] | [A B]]; rewrite A; rewrite B; simpl. - apply Val.lessdef_trans with (Val.hiword (Val.longofwords (ls l1) (ls l2))). - apply Val.hiword_lessdef; auto. apply val_hiword_longofwords. - apply Val.lessdef_trans with (Val.loword (Val.longofwords (ls l1) (ls l2))). - apply Val.loword_lessdef; auto. apply val_loword_longofwords. - eapply IHb; eauto. -- (* error case *) - discriminate. -Qed. - -Lemma call_regs_param_values: - forall sg ls, - map (fun p => Locmap.getpair p (call_regs ls)) (loc_parameters sg) - = map (fun p => Locmap.getpair p ls) (loc_arguments sg). -Proof. - intros. unfold loc_parameters. rewrite list_map_compose. - apply list_map_exten; intros. symmetry. - assert (A: forall l, loc_argument_acceptable l -> call_regs ls (parameter_of_argument l) = ls l). - { destruct l as [r | [] ofs ty]; simpl; auto; contradiction. } - exploit loc_arguments_acceptable; eauto. destruct x; simpl; intros. -- auto. -- destruct H0; f_equal; auto. -Qed. - -Lemma return_regs_arg_values: - forall sg ls1 ls2, - tailcall_is_possible sg = true -> - map (fun p => Locmap.getpair p (return_regs ls1 ls2)) (loc_arguments sg) - = map (fun p => Locmap.getpair p ls2) (loc_arguments sg). -Proof. - intros. - apply tailcall_is_possible_correct in H. - apply list_map_exten; intros. - apply Locmap.getpair_exten; intros. - assert (In l (regs_of_rpairs (loc_arguments sg))) by (eapply in_regs_of_rpairs; eauto). - exploit loc_arguments_acceptable_2; eauto. exploit H; eauto. - destruct l; simpl; intros; try contradiction. rewrite H4; auto. -Qed. - -Lemma find_function_tailcall: - forall tge ros ls1 ls2, - ros_compatible_tailcall ros = true -> - find_function tge ros (return_regs ls1 ls2) = find_function tge ros ls2. -Proof. - unfold ros_compatible_tailcall, find_function; intros. - destruct ros as [r|id]; auto. - unfold return_regs. destruct (is_callee_save r). discriminate. auto. -Qed. - -Lemma loadv_int64_split: - forall m a v, - Mem.loadv Mint64 m a = Some v -> Archi.splitlong = true -> - exists v1 v2, - Mem.loadv Mint32 m a = Some (if Archi.big_endian then v1 else v2) - /\ Mem.loadv Mint32 m (Val.add a (Vint (Int.repr 4))) = Some (if Archi.big_endian then v2 else v1) - /\ Val.lessdef (Val.hiword v) v1 - /\ Val.lessdef (Val.loword v) v2. -Proof. - intros. apply Archi.splitlong_ptr32 in H0. - exploit Mem.loadv_int64_split; eauto. intros (v1 & v2 & A & B & C). - exists v1, v2. split; auto. split; auto. - inv C; auto. destruct v1, v2; simpl; auto. - rewrite Int64.hi_ofwords, Int64.lo_ofwords; auto. -Qed. - -Lemma add_equations_builtin_arg_satisf: - forall env rs ls arg arg' e e', - add_equations_builtin_arg env arg arg' e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - induction arg; destruct arg'; simpl; intros; MonadInv; eauto. - eapply add_equation_satisf; eauto. - destruct arg'1; MonadInv. destruct arg'2; MonadInv. eauto using add_equation_satisf. -Qed. - -Lemma add_equations_builtin_arg_lessdef: - forall env (ge: RTL.genv) sp rs ls m arg v, - eval_builtin_arg ge (fun r => rs#r) sp m arg v -> - forall e e' arg', - add_equations_builtin_arg env arg arg' e = Some e' -> - satisf rs ls e' -> - wt_regset env rs -> - exists v', eval_builtin_arg ge ls sp m arg' v' /\ Val.lessdef v v'. -Proof. - induction 1; simpl; intros e e' arg' AE SAT WT; destruct arg'; MonadInv. -- exploit add_equation_lessdef; eauto. simpl; intros. - exists (ls x0); auto with barg. -- destruct arg'1; MonadInv. destruct arg'2; MonadInv. - exploit add_equation_lessdef. eauto. simpl; intros LD1. - exploit add_equation_lessdef. eapply add_equation_satisf. eauto. simpl; intros LD2. - exists (Val.longofwords (ls x0) (ls x1)); split; auto with barg. - rewrite <- (val_longofwords_eq_2 rs#x); auto. apply Val.longofwords_lessdef; auto. - rewrite <- e0; apply WT. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- econstructor; eauto with barg. -- exploit IHeval_builtin_arg1; eauto. eapply add_equations_builtin_arg_satisf; eauto. - intros (v1 & A & B). - exploit IHeval_builtin_arg2; eauto. intros (v2 & C & D). - exists (Val.longofwords v1 v2); split; auto with barg. apply Val.longofwords_lessdef; auto. -- exploit IHeval_builtin_arg1; eauto. eapply add_equations_builtin_arg_satisf; eauto. - intros (v1' & A & B). - exploit IHeval_builtin_arg2; eauto. intros (v2' & C & D). - econstructor; split. eauto with barg. - destruct Archi.ptr64; auto using Val.add_lessdef, Val.addl_lessdef. -Qed. - -Lemma add_equations_builtin_args_satisf: - forall env rs ls arg arg' e e', - add_equations_builtin_args env arg arg' e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - induction arg; destruct arg'; simpl; intros; MonadInv; eauto using add_equations_builtin_arg_satisf. -Qed. - -Lemma add_equations_builtin_args_lessdef: - forall env (ge: RTL.genv) sp rs ls m tm arg vl, - eval_builtin_args ge (fun r => rs#r) sp m arg vl -> - forall arg' e e', - add_equations_builtin_args env arg arg' e = Some e' -> - satisf rs ls e' -> - wt_regset env rs -> - Mem.extends m tm -> - exists vl', eval_builtin_args ge ls sp tm arg' vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 1; simpl; intros; destruct arg'; MonadInv. -- exists (@nil val); split; constructor. -- exploit IHlist_forall2; eauto. intros (vl' & A & B). - exploit add_equations_builtin_arg_lessdef; eauto. - eapply add_equations_builtin_args_satisf; eauto. intros (v1' & C & D). - exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). - exists (v1'' :: vl'); split; constructor; auto. eapply Val.lessdef_trans; eauto. -Qed. - -Lemma add_equations_debug_args_satisf: - forall env rs ls arg arg' e e', - add_equations_debug_args env arg arg' e = Some e' -> - satisf rs ls e' -> satisf rs ls e. -Proof. - induction arg; destruct arg'; simpl; intros; MonadInv; auto. - destruct (add_equations_builtin_arg env a b e) as [e1|] eqn:A; - eauto using add_equations_builtin_arg_satisf. -Qed. - -Lemma add_equations_debug_args_eval: - forall env (ge: RTL.genv) sp rs ls m tm arg vl, - eval_builtin_args ge (fun r => rs#r) sp m arg vl -> - forall arg' e e', - add_equations_debug_args env arg arg' e = Some e' -> - satisf rs ls e' -> - wt_regset env rs -> - Mem.extends m tm -> - exists vl', eval_builtin_args ge ls sp tm arg' vl'. -Proof. - induction 1; simpl; intros; destruct arg'; MonadInv. -- exists (@nil val); constructor. -- exists (@nil val); constructor. -- destruct (add_equations_builtin_arg env a1 b e) as [e1|] eqn:A. -+ exploit IHlist_forall2; eauto. intros (vl' & B). - exploit add_equations_builtin_arg_lessdef; eauto. - eapply add_equations_debug_args_satisf; eauto. intros (v1' & C & D). - exploit (@eval_builtin_arg_lessdef _ ge ls ls); eauto. intros (v1'' & E & F). - exists (v1'' :: vl'); constructor; auto. -+ eauto. -Qed. - -Lemma add_equations_builtin_eval: - forall ef env args args' e1 e2 m1 m1' rs ls (ge: RTL.genv) sp vargs t vres m2, - wt_regset env rs -> - match ef with - | EF_debug _ _ _ => add_equations_debug_args env args args' e1 - | _ => add_equations_builtin_args env args args' e1 - end = Some e2 -> - Mem.extends m1 m1' -> - satisf rs ls e2 -> - eval_builtin_args ge (fun r => rs # r) sp m1 args vargs -> - external_call ef ge vargs m1 t vres m2 -> - satisf rs ls e1 /\ - exists vargs' vres' m2', - eval_builtin_args ge ls sp m1' args' vargs' - /\ external_call ef ge vargs' m1' t vres' m2' - /\ Val.lessdef vres vres' - /\ Mem.extends m2 m2'. -Proof. - intros. - assert (DEFAULT: add_equations_builtin_args env args args' e1 = Some e2 -> - satisf rs ls e1 /\ - exists vargs' vres' m2', - eval_builtin_args ge ls sp m1' args' vargs' - /\ external_call ef ge vargs' m1' t vres' m2' - /\ Val.lessdef vres vres' - /\ Mem.extends m2 m2'). - { - intros. split. eapply add_equations_builtin_args_satisf; eauto. - exploit add_equations_builtin_args_lessdef; eauto. - intros (vargs' & A & B). - exploit external_call_mem_extends; eauto. - intros (vres' & m2' & C & D & E & F). - exists vargs', vres', m2'; auto. - } - destruct ef; auto. - split. eapply add_equations_debug_args_satisf; eauto. - exploit add_equations_debug_args_eval; eauto. - intros (vargs' & A). - simpl in H4; inv H4. - exists vargs', Vundef, m1'. intuition auto. simpl. constructor. -Qed. - -Lemma parallel_set_builtin_res_satisf: - forall env res res' e0 e1 rs ls v v', - remove_equations_builtin_res env res res' e0 = Some e1 -> - forallb (fun r => reg_unconstrained r e1) (params_of_builtin_res res) = true -> - forallb (fun mr => loc_unconstrained (R mr) e1) (params_of_builtin_res res') = true -> - satisf rs ls e1 -> - Val.lessdef v v' -> - satisf (regmap_setres res v rs) (Locmap.setres res' v' ls) e0. -Proof. - intros. rewrite forallb_forall in *. - destruct res, res'; simpl in *; inv H. -- apply parallel_assignment_satisf with (k := Full); auto. - unfold reg_loc_unconstrained. rewrite H0 by auto. rewrite H1 by auto. auto. -- destruct res'1; try discriminate. destruct res'2; try discriminate. - rename x0 into hi; rename x1 into lo. MonadInv. destruct (mreg_eq hi lo); inv H5. - set (e' := remove_equation {| ekind := High; ereg := x; eloc := R hi |} e0) in *. - set (e'' := remove_equation {| ekind := Low; ereg := x; eloc := R lo |} e') in *. - simpl in *. red; intros. - destruct (OrderedEquation.eq_dec q (Eq Low x (R lo))). - subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gss. apply Val.loword_lessdef; auto. - destruct (OrderedEquation.eq_dec q (Eq High x (R hi))). - subst q; simpl. rewrite Regmap.gss. rewrite Locmap.gso by (red; auto). - rewrite Locmap.gss. apply Val.hiword_lessdef; auto. - assert (EqSet.In q e''). - { unfold e'', e', remove_equation; simpl; ESD.fsetdec. } - rewrite Regmap.gso. rewrite ! Locmap.gso. auto. - eapply loc_unconstrained_sound; eauto. - eapply loc_unconstrained_sound; eauto. - eapply reg_unconstrained_sound; eauto. -- auto. -Qed. - -(** * Properties of the dataflow analysis *) - -Lemma analyze_successors: - forall f env bsh an pc bs s e, - analyze f env bsh = Some an -> - bsh!pc = Some bs -> - In s (successors_block_shape bs) -> - an!!pc = OK e -> - exists e', transfer f env bsh s an!!s = OK e' /\ EqSet.Subset e' e. -Proof. - unfold analyze; intros. exploit DS.fixpoint_allnodes_solution; eauto. - rewrite H2. unfold DS.L.ge. destruct (transfer f env bsh s an#s); intros. - exists e0; auto. - contradiction. -Qed. - -Lemma satisf_successors: - forall f env bsh an pc bs s e rs ls, - analyze f env bsh = Some an -> - bsh!pc = Some bs -> - In s (successors_block_shape bs) -> - an!!pc = OK e -> - satisf rs ls e -> - exists e', transfer f env bsh s an!!s = OK e' /\ satisf rs ls e'. -Proof. - intros. exploit analyze_successors; eauto. intros [e' [A B]]. - exists e'; split; auto. eapply satisf_incr; eauto. -Qed. - -(** Inversion on [transf_function] *) - -Inductive transf_function_spec (f: RTL.function) (tf: LTL.function) : Prop := - | transf_function_spec_intro: - forall env an mv k e1 e2, - wt_function f env -> - analyze f env (pair_codes f tf) = Some an -> - (LTL.fn_code tf)!(LTL.fn_entrypoint tf) = Some(expand_moves mv (Lbranch (RTL.fn_entrypoint f) :: k)) -> - wf_moves mv -> - transfer f env (pair_codes f tf) (RTL.fn_entrypoint f) an!!(RTL.fn_entrypoint f) = OK e1 -> - track_moves env mv e1 = Some e2 -> - compat_entry (RTL.fn_params f) (loc_parameters (fn_sig tf)) e2 = true -> - can_undef destroyed_at_function_entry e2 = true -> - RTL.fn_stacksize f = LTL.fn_stacksize tf -> - RTL.fn_sig f = LTL.fn_sig tf -> - transf_function_spec f tf. - -Lemma transf_function_inv: - forall f tf, - transf_function f = OK tf -> - transf_function_spec f tf. -Proof. - unfold transf_function; intros. - destruct (type_function f) as [env|] eqn:TY; try discriminate. - destruct (regalloc f); try discriminate. - destruct (check_function f f0 env) as [] eqn:?; inv H. - unfold check_function in Heqr. - destruct (analyze f env (pair_codes f tf)) as [an|] eqn:?; try discriminate. - monadInv Heqr. - destruct (check_entrypoints_aux f tf env x) as [y|] eqn:?; try discriminate. - unfold check_entrypoints_aux, pair_entrypoints in Heqo0. MonadInv. - exploit extract_moves_ext_sound; eauto. intros [A B]. subst b. - exploit check_succ_sound; eauto. intros [k EQ1]. subst b0. - econstructor; eauto. eapply type_function_correct; eauto. congruence. -Qed. - -Lemma invert_code: - forall f env tf pc i opte e, - wt_function f env -> - (RTL.fn_code f)!pc = Some i -> - transfer f env (pair_codes f tf) pc opte = OK e -> - exists eafter, exists bsh, exists bb, - opte = OK eafter /\ - (pair_codes f tf)!pc = Some bsh /\ - (LTL.fn_code tf)!pc = Some bb /\ - expand_block_shape bsh i bb /\ - transfer_aux f env bsh eafter = Some e /\ - wt_instr f env i. -Proof. - intros. destruct opte as [eafter|]; simpl in H1; try discriminate. exists eafter. - destruct (pair_codes f tf)!pc as [bsh|] eqn:?; try discriminate. exists bsh. - exploit matching_instr_block; eauto. intros [bb [A B]]. - destruct (transfer_aux f env bsh eafter) as [e1|] eqn:?; inv H1. - exists bb. exploit wt_instr_at; eauto. - tauto. -Qed. - -(** * Semantic preservation *) - -Section PRESERVATION. - -Variable prog: RTL.program. -Variable tprog: LTL.program. -Hypothesis TRANSF: match_prog prog tprog. - -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall (v: val) (f: RTL.fundef), - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial TRANSF). - -Lemma function_ptr_translated: - forall (b: block) (f: RTL.fundef), - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma sig_function_translated: - forall f tf, - transf_fundef f = OK tf -> - LTL.funsig tf = RTL.funsig f. -Proof. - intros; destruct f; monadInv H. - destruct (transf_function_inv _ _ EQ). simpl; auto. - auto. -Qed. - -Lemma find_function_translated: - forall ros rs fd ros' e e' ls, - RTL.find_function ge ros rs = Some fd -> - add_equation_ros ros ros' e = Some e' -> - satisf rs ls e' -> - exists tfd, - LTL.find_function tge ros' ls = Some tfd /\ transf_fundef fd = OK tfd. -Proof. - unfold RTL.find_function, LTL.find_function; intros. - destruct ros as [r|id]; destruct ros' as [r'|id']; simpl in H0; MonadInv. - (* two regs *) - exploit add_equation_lessdef; eauto. intros LD. inv LD. - eapply functions_translated; eauto. - rewrite <- H2 in H. simpl in H. congruence. - (* two symbols *) - rewrite symbols_preserved. rewrite Heqo. - eapply function_ptr_translated; eauto. -Qed. - -Lemma exec_moves: - forall mv env rs s f sp bb m e e' ls, - track_moves env mv e = Some e' -> - wf_moves mv -> - satisf rs ls e' -> - wt_regset env rs -> - exists ls', - star step tge (Block s f sp (expand_moves mv bb) ls m) - E0 (Block s f sp bb ls' m) - /\ satisf rs ls' e. -Proof. -Opaque destroyed_by_op. - induction mv; simpl; intros. - (* base *) -- unfold expand_moves; simpl. inv H. exists ls; split. apply star_refl. auto. - (* step *) -- assert (wf_moves mv) by (inv H0; auto). - destruct a; unfold expand_moves; simpl; MonadInv. -+ (* loc-loc move *) - destruct src as [rsrc | ssrc]; destruct dst as [rdst | sdst]. -* (* reg-reg *) - exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. simpl. eauto. auto. auto. -* (* reg->stack *) - exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. simpl. eauto. auto. -* (* stack->reg *) - simpl in Heqb. exploit IHmv; eauto. eapply subst_loc_undef_satisf; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. auto. auto. -* (* stack->stack *) - inv H0. simpl in H6. contradiction. -+ (* makelong *) - exploit IHmv; eauto. eapply subst_loc_pair_satisf_makelong; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. simpl; eauto. reflexivity. traceEq. -+ (* lowlong *) - exploit IHmv; eauto. eapply subst_loc_part_satisf_lowlong; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. simpl; eauto. reflexivity. traceEq. -+ (* highlong *) - exploit IHmv; eauto. eapply subst_loc_part_satisf_highlong; eauto. - intros [ls' [A B]]. exists ls'; split; auto. eapply star_left; eauto. - econstructor. simpl; eauto. reflexivity. traceEq. -Qed. - -(** The simulation relation *) - -Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> signature -> Prop := - | match_stackframes_nil: forall sg, - sg.(sig_res) = Tint -> - match_stackframes nil nil sg - | match_stackframes_cons: - forall res f sp pc rs s tf bb ls ts sg an e env - (STACKS: match_stackframes s ts (fn_sig tf)) - (FUN: transf_function f = OK tf) - (ANL: analyze f env (pair_codes f tf) = Some an) - (EQ: transfer f env (pair_codes f tf) pc an!!pc = OK e) - (WTF: wt_function f env) - (WTRS: wt_regset env rs) - (WTRES: env res = proj_sig_res sg) - (STEPS: forall v ls1 m, - Val.lessdef v (Locmap.getpair (map_rpair R (loc_result sg)) ls1) -> - Val.has_type v (env res) -> - agree_callee_save ls ls1 -> - exists ls2, - star LTL.step tge (Block ts tf sp bb ls1 m) - E0 (State ts tf sp pc ls2 m) - /\ satisf (rs#res <- v) ls2 e), - match_stackframes - (RTL.Stackframe res f sp pc rs :: s) - (LTL.Stackframe tf sp ls bb :: ts) - sg. - -Inductive match_states: RTL.state -> LTL.state -> Prop := - | match_states_intro: - forall s f sp pc rs m ts tf ls m' an e env - (STACKS: match_stackframes s ts (fn_sig tf)) - (FUN: transf_function f = OK tf) - (ANL: analyze f env (pair_codes f tf) = Some an) - (EQ: transfer f env (pair_codes f tf) pc an!!pc = OK e) - (SAT: satisf rs ls e) - (MEM: Mem.extends m m') - (WTF: wt_function f env) - (WTRS: wt_regset env rs), - match_states (RTL.State s f sp pc rs m) - (LTL.State ts tf sp pc ls m') - | match_states_call: - forall s f args m ts tf ls m' - (STACKS: match_stackframes s ts (funsig tf)) - (FUN: transf_fundef f = OK tf) - (ARGS: Val.lessdef_list args (map (fun p => Locmap.getpair p ls) (loc_arguments (funsig tf)))) - (AG: agree_callee_save (parent_locset ts) ls) - (MEM: Mem.extends m m') - (WTARGS: Val.has_type_list args (sig_args (funsig tf))), - match_states (RTL.Callstate s f args m) - (LTL.Callstate ts tf ls m') - | match_states_return: - forall s res m ts ls m' sg - (STACKS: match_stackframes s ts sg) - (RES: Val.lessdef res (Locmap.getpair (map_rpair R (loc_result sg)) ls)) - (AG: agree_callee_save (parent_locset ts) ls) - (MEM: Mem.extends m m') - (WTRES: Val.has_type res (proj_sig_res sg)), - match_states (RTL.Returnstate s res m) - (LTL.Returnstate ts ls m'). - -Lemma match_stackframes_change_sig: - forall s ts sg sg', - match_stackframes s ts sg -> - sg'.(sig_res) = sg.(sig_res) -> - match_stackframes s ts sg'. -Proof. - intros. inv H. - constructor. congruence. - econstructor; eauto. - unfold proj_sig_res in *. rewrite H0; auto. - intros. rewrite (loc_result_exten sg' sg) in H by auto. eauto. -Qed. - -Ltac UseShape := - match goal with - | [ WT: wt_function _ _, CODE: (RTL.fn_code _)!_ = Some _, EQ: transfer _ _ _ _ _ = OK _ |- _ ] => - destruct (invert_code _ _ _ _ _ _ _ WT CODE EQ) as (eafter & bsh & bb & AFTER & BSH & TCODE & EBS & TR & WTI); - inv EBS; unfold transfer_aux in TR; MonadInv - end. - -Remark addressing_not_long: - forall trap env f addr args dst s r, - wt_instr f env (Iload trap Mint64 addr args dst s) -> Archi.splitlong = true -> - In r args -> r <> dst. -Proof. - intros. inv H. - assert (A: forall ty, In ty (type_of_addressing addr) -> ty = Tptr). - { intros. destruct addr; simpl in H; intuition. } - assert (B: In (env r) (type_of_addressing addr)). - { rewrite <- H5. apply in_map; auto. } - assert (C: env r = Tint). - { apply A in B. rewrite B. unfold Tptr. rewrite Archi.splitlong_ptr32 by auto. auto. } - red; intros; subst r. rewrite C in H9; discriminate. -Qed. - -(** The proof of semantic preservation is a simulation argument of the - "plus" kind. *) - -Lemma step_simulation: - forall S1 t S2, RTL.step ge S1 t S2 -> wt_state S1 -> - forall S1', match_states S1 S1' -> - exists S2', plus LTL.step tge S1' t S2' /\ match_states S2 S2'. -Proof. - induction 1; intros WT S1' MS; inv MS; try UseShape. - -(* nop *) -- exploit exec_moves; eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - -(* op move *) -- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. - simpl in H0. inv H0. - exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. eapply subst_reg_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* op makelong *) -- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. - simpl in H0. inv H0. - exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - eapply subst_reg_kind_satisf_makelong. eauto. eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* op lowlong *) -- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. - simpl in H0. inv H0. - exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - eapply subst_reg_kind_satisf_lowlong. eauto. eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* op highlong *) -- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. - simpl in H0. inv H0. - exploit (exec_moves mv); eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - eapply subst_reg_kind_satisf_highlong. eauto. eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* op regular *) -- generalize (wt_exec_Iop _ _ _ _ _ _ _ _ _ _ _ WTI H0 WTRS). intros WTRS'. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit transfer_use_def_satisf; eauto. intros [X Y]. - exploit eval_operation_lessdef; eauto. intros [v' [F G]]. - exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. instantiate (1 := v'). rewrite <- F. - apply eval_operation_preserved. exact symbols_preserved. - eauto. eapply star_right. eexact A2. constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - -(* op dead *) -- exploit exec_moves; eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. - eapply reg_unconstrained_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - eapply wt_exec_Iop; eauto. - -(* load regular TRAP *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit transfer_use_def_satisf; eauto. intros [X Y]. - exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. - exploit Mem.loadv_extends; eauto. intros [v' [P Q]]. - exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. instantiate (1 := a'). rewrite <- F. - apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. - eapply star_right. eexact A2. constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - -(* load pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. - exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). - set (v2' := if Archi.big_endian then v2 else v1) in *. - set (v1' := if Archi.big_endian then v1 else v2) in *. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - assert (LD1: Val.lessdef_list rs##args (reglist ls1 args1')). - { eapply add_equations_lessdef; eauto. } - exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. - exploit Mem.loadv_extends. eauto. eexact LOAD1. eexact G1. intros (v1'' & LOAD1' & LD2). - set (ls2 := Locmap.set (R dst1') v1'' (undef_regs (destroyed_by_load Mint32 addr) ls1)). - assert (SAT2: satisf (rs#dst <- v) ls2 e2). - { eapply loc_unconstrained_satisf. eapply can_undef_satisf; eauto. - eapply reg_unconstrained_satisf. eauto. - eapply add_equations_satisf; eauto. assumption. - rewrite Regmap.gss. - apply Val.lessdef_trans with v1'; unfold sel_val; unfold kind_first_word; unfold v1'; destruct Archi.big_endian; auto. - } - exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. - assert (LD3: Val.lessdef_list rs##args (reglist ls3 args2')). - { replace (rs##args) with ((rs#dst<-v)##args). - eapply add_equations_lessdef; eauto. - apply list_map_exten; intros. rewrite Regmap.gso; auto. - eapply addressing_not_long; eauto. - } - exploit eval_addressing_lessdef. eexact LD3. - eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. - intros [a2' [F2 G2]]. - assert (LOADX: exists v2'', Mem.loadv Mint32 m' a2' = Some v2'' /\ Val.lessdef v2' v2''). - { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G2]). } - destruct LOADX as (v2'' & LOAD2' & LD4). - set (ls4 := Locmap.set (R dst2') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls3)). - assert (SAT4: satisf (rs#dst <- v) ls4 e0). - { eapply loc_unconstrained_satisf. eapply can_undef_satisf; eauto. - eapply add_equations_satisf; eauto. assumption. - rewrite Regmap.gss. - apply Val.lessdef_trans with v2'; unfold sel_val; unfold kind_second_word; unfold v2'; destruct Archi.big_endian; auto. - } - exploit (exec_moves mv3); eauto. intros [ls5 [A5 B5]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. - instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. - eexact LOAD1'. instantiate (1 := ls2); auto. - eapply star_trans. eexact A3. - eapply star_left. econstructor. - instantiate (1 := a2'). rewrite <- F2. apply eval_addressing_preserved. exact symbols_preserved. - eexact LOAD2'. instantiate (1 := ls4); auto. - eapply star_right. eexact A5. - constructor. - eauto. eauto. eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. - econstructor; eauto. - -(* load first word of a pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. - exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). - set (v2' := if Archi.big_endian then v2 else v1) in *. - set (v1' := if Archi.big_endian then v1 else v2) in *. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - assert (LD1: Val.lessdef_list rs##args (reglist ls1 args')). - { eapply add_equations_lessdef; eauto. } - exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. - exploit Mem.loadv_extends. eauto. eexact LOAD1. eexact G1. intros (v1'' & LOAD1' & LD2). - set (ls2 := Locmap.set (R dst') v1'' (undef_regs (destroyed_by_load Mint32 addr) ls1)). - assert (SAT2: satisf (rs#dst <- v) ls2 e0). - { eapply parallel_assignment_satisf; eauto. - apply Val.lessdef_trans with v1'; - unfold sel_val; unfold kind_first_word; unfold v1'; destruct Archi.big_endian; auto. - eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. - } - exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. - instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. - eexact LOAD1'. instantiate (1 := ls2); auto. - eapply star_right. eexact A3. - constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. - econstructor; eauto. - -(* load second word of a pair *) -- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'. - exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2). - set (v2' := if Archi.big_endian then v2 else v1) in *. - set (v1' := if Archi.big_endian then v1 else v2) in *. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - assert (LD1: Val.lessdef_list rs##args (reglist ls1 args')). - { eapply add_equations_lessdef; eauto. } - exploit eval_addressing_lessdef. eexact LD1. - eapply eval_offset_addressing; eauto; apply Archi.splitlong_ptr32; auto. - intros [a1' [F1 G1]]. - assert (LOADX: exists v2'', Mem.loadv Mint32 m' a1' = Some v2'' /\ Val.lessdef v2' v2''). - { discriminate || (eapply Mem.loadv_extends; [eauto|eexact LOAD2|eexact G1]). } - destruct LOADX as (v2'' & LOAD2' & LD2). - set (ls2 := Locmap.set (R dst') v2'' (undef_regs (destroyed_by_load Mint32 addr2) ls1)). - assert (SAT2: satisf (rs#dst <- v) ls2 e0). - { eapply parallel_assignment_satisf; eauto. - apply Val.lessdef_trans with v2'; unfold sel_val; unfold kind_second_word; unfold v2'; destruct Archi.big_endian; auto. - eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. - } - exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. - instantiate (1 := a1'). rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. - eexact LOAD2'. instantiate (1 := ls2); auto. - eapply star_right. eexact A3. - constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [W Z]]. - econstructor; eauto. - -(* load dead *) -- exploit exec_moves; eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. - eapply reg_unconstrained_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - eapply wt_exec_Iload; eauto. - -- (* load notrap1 *) - generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). - intro WTRS'. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit transfer_use_def_satisf; eauto. intros [X Y]. - exploit eval_addressing_lessdef_none; eauto. intro Haddr. - exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. eapply exec_Lload_notrap1. rewrite <- Haddr. - apply eval_addressing_preserved. exact symbols_preserved. eauto. - - eapply star_right. eexact A2. constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - -(* load notrap1 dead *) -- exploit exec_moves; eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. - eapply reg_unconstrained_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - eapply wt_exec_Iload_notrap; eauto. - -(* load regular notrap2 *) -- generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS). - intro WTRS'. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit transfer_use_def_satisf; eauto. intros [X Y]. - exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. - destruct (Mem.loadv chunk m' a') as [v' |] eqn:Hload. - { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. instantiate (1 := a'). rewrite <- F. - apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. - eapply star_right. eexact A2. constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - } - { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. eapply exec_Lload_notrap2. rewrite <- F. - apply eval_addressing_preserved. exact symbols_preserved. assumption. - eauto. - eapply star_right. eexact A2. constructor. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]]. - econstructor; eauto. - } - -- (* load notrap2 dead *) - exploit exec_moves; eauto. intros [ls1 [X Y]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact X. econstructor; eauto. - eauto. traceEq. - exploit satisf_successors. eauto. eauto. simpl; eauto. eauto. - eapply reg_unconstrained_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - eapply wt_exec_Iload_notrap; eauto. - -(* store *) -- exploit exec_moves; eauto. intros [ls1 [X Y]]. - exploit add_equations_lessdef; eauto. intros LD. simpl in LD. inv LD. - exploit eval_addressing_lessdef; eauto. intros [a' [F G]]. - exploit Mem.storev_extends; eauto. intros [m'' [P Q]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact X. - eapply star_two. econstructor. instantiate (1 := a'). rewrite <- F. - apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto. - constructor. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - eapply can_undef_satisf; eauto. eapply add_equations_satisf; eauto. intros [enext [U V]]. - econstructor; eauto. - -(* store 2 *) -- assert (SF: Archi.ptr64 = false) by (apply Archi.splitlong_ptr32; auto). - exploit Mem.storev_int64_split; eauto. - replace (if Archi.big_endian then Val.hiword rs#src else Val.loword rs#src) - with (sel_val kind_first_word rs#src) - by (unfold kind_first_word; destruct Archi.big_endian; reflexivity). - replace (if Archi.big_endian then Val.loword rs#src else Val.hiword rs#src) - with (sel_val kind_second_word rs#src) - by (unfold kind_second_word; destruct Archi.big_endian; reflexivity). - intros [m1 [STORE1 STORE2]]. - exploit (exec_moves mv1); eauto. intros [ls1 [X Y]]. - exploit add_equations_lessdef. eexact Heqo1. eexact Y. intros LD1. - exploit add_equation_lessdef. eapply add_equations_satisf. eexact Heqo1. eexact Y. - simpl. intros LD2. - set (ls2 := undef_regs (destroyed_by_store Mint32 addr) ls1). - assert (SAT2: satisf rs ls2 e1). - eapply can_undef_satisf. eauto. - eapply add_equation_satisf. eapply add_equations_satisf; eauto. - exploit eval_addressing_lessdef. eexact LD1. eauto. intros [a1' [F1 G1]]. - assert (F1': eval_addressing tge sp addr (reglist ls1 args1') = Some a1'). - rewrite <- F1. apply eval_addressing_preserved. exact symbols_preserved. - exploit Mem.storev_extends. eauto. eexact STORE1. eexact G1. eauto. - intros [m1' [STORE1' EXT1]]. - exploit (exec_moves mv2); eauto. intros [ls3 [U V]]. - exploit add_equations_lessdef. eexact Heqo. eexact V. intros LD3. - exploit add_equation_lessdef. eapply add_equations_satisf. eexact Heqo. eexact V. - simpl. intros LD4. - exploit eval_addressing_lessdef. eexact LD3. eauto. intros [a2' [F2 G2]]. - assert (F2': eval_addressing tge sp addr (reglist ls3 args2') = Some a2'). - rewrite <- F2. apply eval_addressing_preserved. exact symbols_preserved. - exploit (eval_offset_addressing tge); eauto. intros F2''. - assert (STOREX: exists m2', Mem.storev Mint32 m1' (Val.add a2' (Vint (Int.repr 4))) (ls3 (R src2')) = Some m2' /\ Mem.extends m' m2'). - { try discriminate; - (eapply Mem.storev_extends; - [eexact EXT1 | eexact STORE2 | apply Val.add_lessdef; [eexact G2|eauto] | eauto]). } - destruct STOREX as [m2' [STORE2' EXT2]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact X. - eapply star_left. - econstructor. eexact F1'. eexact STORE1'. instantiate (1 := ls2). auto. - eapply star_trans. eexact U. - eapply star_two. - eapply exec_Lstore with (m' := m2'). eexact F2''. discriminate||exact STORE2'. eauto. - constructor. eauto. eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - eapply can_undef_satisf. eauto. - eapply add_equation_satisf. eapply add_equations_satisf; eauto. - intros [enext [P Q]]. - econstructor; eauto. - -(* call *) -- set (sg := RTL.funsig fd) in *. - set (args' := loc_arguments sg) in *. - set (res' := loc_result sg) in *. - exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit find_function_translated. eauto. eauto. eapply add_equations_args_satisf; eauto. - intros [tfd [E F]]. - assert (SIG: funsig tfd = sg). eapply sig_function_translated; eauto. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. econstructor; eauto. - eauto. traceEq. - exploit analyze_successors; eauto. simpl. left; eauto. intros [enext [U V]]. - econstructor; eauto. - econstructor; eauto. - inv WTI. congruence. - intros. exploit (exec_moves mv2). eauto. eauto. - eapply function_return_satisf with (v := v) (ls_before := ls1) (ls_after := ls0); eauto. - eapply add_equation_ros_satisf; eauto. - eapply add_equations_args_satisf; eauto. - congruence. - apply wt_regset_assign; auto. - intros [ls2 [A2 B2]]. - exists ls2; split. - eapply star_right. eexact A2. constructor. traceEq. - apply satisf_incr with eafter; auto. - rewrite SIG. eapply add_equations_args_lessdef; eauto. - inv WTI. rewrite <- H7. apply wt_regset_list; auto. - simpl. red; auto. - inv WTI. rewrite SIG. rewrite <- H7. apply wt_regset_list; auto. - -(* tailcall *) -- set (sg := RTL.funsig fd) in *. - set (args' := loc_arguments sg) in *. - exploit Mem.free_parallel_extends; eauto. intros [m'' [P Q]]. - exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. - exploit find_function_translated. eauto. eauto. eapply add_equations_args_satisf; eauto. - intros [tfd [E F]]. - assert (SIG: funsig tfd = sg). eapply sig_function_translated; eauto. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. econstructor; eauto. - rewrite <- E. apply find_function_tailcall; auto. - replace (fn_stacksize tf) with (RTL.fn_stacksize f); eauto. - destruct (transf_function_inv _ _ FUN); auto. - eauto. traceEq. - econstructor; eauto. - eapply match_stackframes_change_sig; eauto. rewrite SIG. rewrite e0. decEq. - destruct (transf_function_inv _ _ FUN); auto. - rewrite SIG. rewrite return_regs_arg_values; auto. eapply add_equations_args_lessdef; eauto. - inv WTI. rewrite <- H6. apply wt_regset_list; auto. - apply return_regs_agree_callee_save. - rewrite SIG. inv WTI. rewrite <- H6. apply wt_regset_list; auto. - -(* builtin *) -- exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]]. - exploit add_equations_builtin_eval; eauto. - intros (C & vargs' & vres' & m'' & D & E & F & G). - assert (WTRS': wt_regset env (regmap_setres res vres rs)) by (eapply wt_exec_Ibuiltin; eauto). - set (ls2 := Locmap.setres res' vres' (undef_regs (destroyed_by_builtin ef) ls1)). - assert (satisf (regmap_setres res vres rs) ls2 e0). - { eapply parallel_set_builtin_res_satisf; eauto. - eapply can_undef_satisf; eauto. } - exploit (exec_moves mv2); eauto. intros [ls3 [A3 B3]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_trans. eexact A1. - eapply star_left. econstructor. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. apply senv_preserved. eauto. - instantiate (1 := ls2); auto. - eapply star_right. eexact A3. - econstructor. - reflexivity. reflexivity. reflexivity. traceEq. - exploit satisf_successors; eauto. simpl; eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* cond *) -- exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. - econstructor. eapply eval_condition_lessdef; eauto. eapply add_equations_lessdef; eauto. - eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. - instantiate (1 := if b then ifso else ifnot). simpl. destruct b; auto. - eapply can_undef_satisf. eauto. eapply add_equations_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* jumptable *) -- exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. - assert (Val.lessdef (Vint n) (ls1 (R arg'))). - rewrite <- H0. eapply add_equation_lessdef with (q := Eq Full arg (R arg')); eauto. - inv H2. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. - econstructor. eauto. eauto. eauto. eauto. traceEq. - exploit satisf_successors; eauto. - instantiate (1 := pc'). simpl. eapply list_nth_z_in; eauto. - eapply can_undef_satisf. eauto. eapply add_equation_satisf; eauto. - intros [enext [U V]]. - econstructor; eauto. - -(* return *) -- destruct (transf_function_inv _ _ FUN). - exploit Mem.free_parallel_extends; eauto. rewrite H10. intros [m'' [P Q]]. - inv WTI; MonadInv. -+ (* without an argument *) - exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. - econstructor. eauto. eauto. traceEq. - simpl. econstructor; eauto. - apply return_regs_agree_callee_save. - constructor. -+ (* with an argument *) - exploit (exec_moves mv); eauto. intros [ls1 [A1 B1]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_right. eexact A1. - econstructor. eauto. eauto. traceEq. - simpl. econstructor; eauto. rewrite <- H11. - replace (Locmap.getpair (map_rpair R (loc_result (RTL.fn_sig f))) - (return_regs (parent_locset ts) ls1)) - with (Locmap.getpair (map_rpair R (loc_result (RTL.fn_sig f))) ls1). - eapply add_equations_res_lessdef; eauto. - rewrite <- H14. apply WTRS. - generalize (loc_result_caller_save (RTL.fn_sig f)). - destruct (loc_result (RTL.fn_sig f)); simpl. - intros A; rewrite A; auto. - intros [A B]; rewrite A, B; auto. - apply return_regs_agree_callee_save. - rewrite <- H11, <- H14. apply WTRS. - -(* internal function *) -- monadInv FUN. simpl in *. - destruct (transf_function_inv _ _ EQ). - exploit Mem.alloc_extends; eauto. apply Z.le_refl. rewrite H8; apply Z.le_refl. - intros [m'' [U V]]. - assert (WTRS: wt_regset env (init_regs args (fn_params f))). - { apply wt_init_regs. inv H0. rewrite wt_params. rewrite H9. auto. } - exploit (exec_moves mv). eauto. eauto. - eapply can_undef_satisf; eauto. eapply compat_entry_satisf; eauto. - rewrite call_regs_param_values. eexact ARGS. - exact WTRS. - intros [ls1 [A B]]. - econstructor; split. - eapply plus_left. econstructor; eauto. - eapply star_left. econstructor; eauto. - eapply star_right. eexact A. - econstructor; eauto. - eauto. eauto. traceEq. - econstructor; eauto. - -(* external function *) -- exploit external_call_mem_extends; eauto. intros [v' [m'' [F [G [J K]]]]]. - simpl in FUN; inv FUN. - econstructor; split. - apply plus_one. econstructor; eauto. - eapply external_call_symbols_preserved with (ge1 := ge); eauto. apply senv_preserved. - econstructor; eauto. - simpl. destruct (loc_result (ef_sig ef)) eqn:RES; simpl. - rewrite Locmap.gss; auto. - generalize (loc_result_pair (ef_sig ef)); rewrite RES; intros (A & B & C & D & E). - assert (WTRES': Val.has_type v' Tlong). - { rewrite <- B. eapply external_call_well_typed; eauto. } - rewrite Locmap.gss. rewrite Locmap.gso by (red; auto). rewrite Locmap.gss. - rewrite val_longofwords_eq_1 by auto. auto. - red; intros. rewrite (AG l H0). - rewrite locmap_get_set_loc_result_callee_save by auto. - unfold undef_caller_save_regs. destruct l; simpl in H0. - rewrite H0; auto. - destruct sl; auto; congruence. - eapply external_call_well_typed; eauto. - -(* return *) -- inv STACKS. - exploit STEPS; eauto. rewrite WTRES0; auto. intros [ls2 [A B]]. - econstructor; split. - eapply plus_left. constructor. eexact A. traceEq. - econstructor; eauto. - apply wt_regset_assign; auto. rewrite WTRES0; auto. -Qed. - -Lemma initial_states_simulation: - forall st1, RTL.initial_state prog st1 -> - exists st2, LTL.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. - exploit sig_function_translated; eauto. intros SIG. - exists (LTL.Callstate nil tf (Locmap.init Vundef) m0); split. - econstructor; eauto. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - rewrite symbols_preserved. - rewrite (match_program_main TRANSF). auto. - congruence. - constructor; auto. - constructor. rewrite SIG; rewrite H3; auto. - rewrite SIG, H3, loc_arguments_main. auto. - red; auto. - apply Mem.extends_refl. - rewrite SIG, H3. constructor. -Qed. - -Lemma final_states_simulation: - forall st1 st2 r, - match_states st1 st2 -> RTL.final_state st1 r -> LTL.final_state st2 r. -Proof. - intros. inv H0. inv H. inv STACKS. - econstructor. rewrite <- (loc_result_exten sg). inv RES; auto. - rewrite H; auto. -Qed. - -Lemma wt_prog: wt_program prog. -Proof. - red; intros. - exploit list_forall2_in_left. eexact (proj1 TRANSF). eauto. - intros ([i' gd] & A & B & C). simpl in *; subst i'. - inv C. destruct f; simpl in *. -- monadInv H2. - unfold transf_function in EQ. - destruct (type_function f) as [env|] eqn:TF; try discriminate. - econstructor. eapply type_function_correct; eauto. -- constructor. -Qed. - -Theorem transf_program_correct: - forward_simulation (RTL.semantics prog) (LTL.semantics tprog). -Proof. - set (ms := fun s s' => wt_state s /\ match_states s s'). - eapply forward_simulation_plus with (match_states := ms). -- apply senv_preserved. -- intros. exploit initial_states_simulation; eauto. intros [st2 [A B]]. - exists st2; split; auto. split; auto. - apply wt_initial_state with (p := prog); auto. exact wt_prog. -- intros. destruct H. eapply final_states_simulation; eauto. -- intros. destruct H0. - exploit step_simulation; eauto. intros [s2' [A B]]. - exists s2'; split. exact A. split. - eapply subject_reduction; eauto. eexact wt_prog. eexact H. - auto. -Qed. - -End PRESERVATION. diff --git a/backend/Tunneling.v b/backend/Tunneling.v index a4c4a195..78458582 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -101,5 +101,5 @@ Definition tunnel_function (f: LTL.function) : LTL.function := Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef := transf_fundef tunnel_function f. -Definition tunnel_program (p: LTL.program) : LTL.program := +Definition transf_program (p: LTL.program) : LTL.program := transform_program tunnel_fundef p. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index d3b8a9f0..cdf6c800 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -22,7 +22,7 @@ Definition match_prog (p tp: program) := match_program (fun ctx f tf => tf = tunnel_fundef f) eq p tp. Lemma transf_program_match: - forall p, match_prog p (tunnel_program p). + forall p, match_prog p (transf_program p). Proof. intros. eapply match_transform_program; eauto. Qed. diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index c044d9ef..17b504b7 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -36,12 +36,6 @@ Require Cminorgen. Require Selection. Require RTLgen. EXPAND_RTL_REQUIRE -Require Allocation. -Require Tunneling. -Require Linearize. -Require CleanupLabels. -Require Debugvar. -Require Stacking. Require Asmgen. (** Proofs of semantic preservation. *) Require SimplExprproof. @@ -51,12 +45,6 @@ Require Cminorgenproof. Require Selectionproof. Require RTLgenproof. EXPAND_RTL_REQUIRE_PROOF -Require Allocproof. -Require Tunnelingproof. -Require Linearizeproof. -Require CleanupLabelsproof. -Require Debugvarproof. -Require Stackingproof. Require Import Asmgenproof. (** Command-line flags. *) Require Import Compopts. @@ -109,16 +97,8 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program := OK f @@ print (print_RTL 0) EXPAND_RTL_TRANSF_PROGRAM - @@@ time "Register allocation" Allocation.transf_program - @@ print print_LTL - @@ time "Branch tunneling" Tunneling.tunnel_program - @@@ time "CFG linearization" Linearize.transf_program - @@ time "Label cleanup" CleanupLabels.transf_program - @@@ partial_if Compopts.debug (time "Debugging info for local variables" Debugvar.transf_program) - @@@ time "Mach generation" Stacking.transf_program - @@ print print_Mach @@@ time "Total Mach->Asm generation" Asmgen.transf_program. - + Definition transf_cminor_program (p: Cminor.program) : res Asm.program := OK p @@ print print_Cminor @@ -209,12 +189,6 @@ Definition CompCert's_passes := ::: mkpass Selectionproof.match_prog ::: mkpass RTLgenproof.match_prog EXPAND_RTL_MKPASS - ::: mkpass Allocproof.match_prog - ::: mkpass Tunnelingproof.match_prog - ::: mkpass Linearizeproof.match_prog - ::: mkpass CleanupLabelsproof.match_prog - ::: mkpass (match_if Compopts.debug Debugvarproof.match_prog) - ::: mkpass Stackingproof.match_prog ::: mkpass Asmgenproof.match_prog ::: pass_nil _. @@ -244,30 +218,7 @@ Proof. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. - destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. - set (p8bis := total_if profile_arcs Profiling.transf_program p8) in *. - set (p8ter := total_if branch_probabilities ProfilingExploit.transf_program p8bis) in *. - set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8ter) in *. - set (p9bis := Renumber.transf_program p9) in *. - destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. - set (p11 := Renumber.transf_program p10) in *. - set (p12 := total_if optim_constprop Constprop.transf_program p11) in *. - destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. - set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. - destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. - set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. - set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. - set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transf_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. - set (p17 := Tunneling.tunnel_program p16) in *. - destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. - set (p19 := CleanupLabels.transf_program p18) in *. - destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. - destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. +EXPAND_RTL_PROOF unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. @@ -275,30 +226,7 @@ Proof. exists p4; split. apply Cminorgenproof.transf_program_match; auto. exists p5; split. apply Selectionproof.transf_program_match; auto. exists p6; split. apply RTLgenproof.transf_program_match; auto. - exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. - exists p8; split. apply Inliningproof.transf_program_match; auto. - exists p8bis; split. apply total_if_match. apply Profilingproof.transf_program_match; auto. - exists p8ter; split. apply total_if_match. apply ProfilingExploitproof.transf_program_match; auto. - exists p9; split. apply total_if_match. apply FirstNopproof.transf_program_match. - exists p9bis; split. apply Renumberproof.transf_program_match. - exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto. - exists p11; split. apply Renumberproof.transf_program_match. - exists p12; split. apply total_if_match. apply Constpropproof.transf_program_match. - exists p12bis; split. eapply partial_if_match; eauto. apply LICMproof.transf_program_match. - exists p12ter; split. apply total_if_match; eauto. apply Renumberproof.transf_program_match. - exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. - exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match. - exists p13ter; split. eapply partial_if_match; eauto. apply CSE3proof.transf_program_match. - exists p13quater; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match. - exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. - exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match. - exists p15; split. apply Unusedglobproof.transf_program_match; auto. - exists p16; split. apply Allocproof.transf_program_match; auto. - exists p17; split. apply Tunnelingproof.transf_program_match. - exists p18; split. apply Linearizeproof.transf_program_match; auto. - exists p19; split. apply CleanupLabelsproof.transf_program_match; auto. - exists p20; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. - exists p21; split. apply Stackingproof.transf_program_match; auto. +EXPAND_RTL_PROOF2 exists tp; split. apply Asmgenproof.transf_program_match; auto. reflexivity. Qed. @@ -350,7 +278,9 @@ Ltac DestructM := destruct H as (p & M & MM); clear H end. repeat DestructM. subst tp. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p31)). + assert (F: forward_simulation (Cstrategy.semantics p) +EXPAND_ASM_SEMANTICS + ). { eapply compose_forward_simulations. eapply SimplExprproof.transl_program_correct; eassumption. @@ -364,42 +294,9 @@ Ltac DestructM := eapply Selectionproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply RTLgenproof.transf_program_correct; eassumption. +EXPAND_RTL_FORWARD_SIMULATIONS eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. - eapply compose_forward_simulations. - eapply Inliningproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Profilingproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact ProfilingExploitproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact FirstNopproof.transf_program_correct. - eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct. - eapply compose_forward_simulations. - eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. - eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact LICMproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSE2proof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact CSE3proof.transf_program_correct. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact ForwardMovesproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply match_if_simulation. eassumption. exact Allnontrapproof.transf_program_correct. - eapply compose_forward_simulations. - eapply Unusedglobproof.transf_program_correct; eassumption. - eapply compose_forward_simulations. - eapply Allocproof.transf_program_correct; eassumption. + eapply Allocationproof.transf_program_correct; eassumption. eapply compose_forward_simulations. eapply Tunnelingproof.transf_program_correct; eassumption. eapply compose_forward_simulations. diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 1ef233e7..1555d75b 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -1,4 +1,5 @@ type is_partial = TOTAL | PARTIAL;; +type print_result = Noprint | Print of string;; type when_triggered = Always | Option of string;; let rtl_passes = @@ -23,21 +24,38 @@ TOTAL, (Option "all_loads_nontrap"), None, "Allnontrap"; PARTIAL, Always, (Some "Unused globals"), "Unusedglob" |];; +let post_rtl_passes = +[| + PARTIAL, Always, (Some "Register allocation"), "Allocation", (Print "LTL"); + TOTAL, Always, (Some "Branch tunneling"), "Tunneling", Noprint; + PARTIAL, Always, (Some "CFG linearization"), "Linearize", Noprint; + TOTAL, Always, (Some "Label cleanup"), "CleanupLabels", Noprint; + PARTIAL, (Option "debug"), (Some "Debugging info for local variables"), "Debugvar", Noprint; + PARTIAL, Always, (Some "Mach generation"), "Stacking", (Print "Mach") +|];; + +let all_passes = + Array.concat + [Array.mapi + (fun i (a,b,c,d) -> (a,b,c,d, Print (Printf.sprintf "RTL %d" (i+1)))) + rtl_passes; + post_rtl_passes];; + let totality = function TOTAL -> "total" | PARTIAL -> "partial";; let print_rtl_require oc = - Array.iter (fun (partial, trigger, time_label, pass_name) -> + Array.iter (fun (partial, trigger, time_label, pass_name, printing) -> Printf.fprintf oc "Require %s.\n" pass_name) - rtl_passes;; + all_passes;; let print_rtl_require_proof oc = - Array.iter (fun (partial, trigger, time_label, pass_name) -> + Array.iter (fun (partial, trigger, time_label, pass_name, printing) -> Printf.fprintf oc "Require %sproof.\n" pass_name) - rtl_passes;; + all_passes;; let print_rtl_transf oc = Array.iteri - (fun i (partial, trigger, time_label, pass_name) -> + (fun i (partial, trigger, time_label, pass_name, printing) -> output_string oc (match partial with | TOTAL -> " @@ " | PARTIAL -> " @@@ "); @@ -51,17 +69,61 @@ let print_rtl_transf oc = | Some s -> Printf.fprintf oc "time \"%s\" " s); Printf.fprintf oc "%s.transf_program)\n" pass_name; - Printf.fprintf oc " @@ print (print_RTL %d)\n" (succ i) - ) rtl_passes;; + (match printing with + | Noprint -> () + | Print s -> + Printf.fprintf oc " @@ print (print_%s)\n" s) + ) all_passes;; let print_rtl_mkpass oc = - Array.iter (fun (partial, trigger, time_label, pass_name) -> + Array.iter (fun (partial, trigger, time_label, pass_name, printing) -> output_string oc " ::: mkpass ("; (match trigger with | Always -> () | Option s -> Printf.fprintf oc "match_if Compopts.%s " s); Printf.fprintf oc "%sproof.match_prog)\n" pass_name) + all_passes;; + +let print_if kind oc = function + | Always -> () + | Option s -> Printf.fprintf oc "%s_if %s " kind s;; + +let numbering_base = 7 + +let print_rtl_proof oc = + Array.iteri (fun i (partial, trigger, time_label, pass_name, printing) -> + let j = i+numbering_base in + match partial with + | TOTAL -> + Printf.fprintf oc "set (p%d := %a%s.transf_program p%d) in *.\n" + j (print_if "total") trigger pass_name (pred j) + | PARTIAL -> + Printf.fprintf oc "destruct (%a%s.transf_program p%d) as [p%d|e] eqn:P%d; simpl in T; try discriminate.\n" + (print_if "partial") trigger pass_name (pred j) j j) + all_passes;; + +let print_rtl_proof2 oc = + Array.iteri (fun i (partial, trigger, time_label, pass_name, printing) -> + let j = i+numbering_base in + Printf.fprintf oc " exists p%d; split. " j; + (match trigger with + | Always -> () + | Option _ -> + (match partial with + | TOTAL -> output_string oc "apply total_if_match. " + | PARTIAL -> output_string oc "eapply partial_if_match; eauto. ")); + Printf.fprintf oc "apply %sproof.transf_program_match; auto.\n" pass_name) + all_passes;; + +let print_rtl_forward_simulations oc = + Array.iter (fun (partial, trigger, time_label, pass_name) -> + output_string oc " eapply compose_forward_simulations.\n "; + (match trigger with + | Always -> () + | Option s -> output_string oc "eapply match_if_simulation. eassumption. "); + Printf.fprintf oc "eapply %sproof.transf_program_correct; eassumption." pass_name + ) rtl_passes;; if (Array.length Sys.argv)<>3 @@ -81,6 +143,15 @@ let filename_in = Sys.argv.(1) and filename_out = Sys.argv.(2) in print_rtl_require_proof oc | "EXPAND_RTL_MKPASS" -> print_rtl_mkpass oc + | "EXPAND_RTL_PROOF" -> + print_rtl_proof oc + | "EXPAND_RTL_PROOF2" -> + print_rtl_proof2 oc + | "EXPAND_ASM_SEMANTICS" -> + Printf.fprintf oc " (Asm.semantics p%d)\n" + ((Array.length all_passes) + 7) + | "EXPAND_RTL_FORWARD_SIMULATIONS" -> + print_rtl_forward_simulations oc | line -> (output_string oc line; output_char oc '\n') done -- cgit From 05a5825ee55227327ba1b09a548e3b9ba876d0cf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 22 Apr 2020 08:53:06 +0200 Subject: use cbn in T instead of simpl in T --- driver/Compiler.vexpand | 3 ++- tools/compiler_expand.ml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index 17b504b7..1e671464 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -217,7 +217,8 @@ Proof. unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. + cbn in T. EXPAND_RTL_PROOF unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 1555d75b..4fc746f0 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -99,7 +99,7 @@ let print_rtl_proof oc = Printf.fprintf oc "set (p%d := %a%s.transf_program p%d) in *.\n" j (print_if "total") trigger pass_name (pred j) | PARTIAL -> - Printf.fprintf oc "destruct (%a%s.transf_program p%d) as [p%d|e] eqn:P%d; simpl in T; try discriminate.\n" + Printf.fprintf oc "destruct (%a%s.transf_program p%d) as [p%d|e] eqn:P%d; cbn in T; try discriminate.\n" (print_if "partial") trigger pass_name (pred j) j j) all_passes;; -- cgit From 9718c8244b561b6f81a7a5a7dd0fb3ff1d570344 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 22 Apr 2020 09:10:15 +0200 Subject: simpl -> cbn --- driver/Compiler.v | 39 ++++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index 499feff2..002c55fe 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -288,34 +288,35 @@ Theorem transf_c_program_match: match_prog p tp. Proof. intros p tp T. - unfold transf_c_program, time in T. simpl in T. - destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. - unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. - destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. - destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. - unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + unfold transf_c_program, time in T. cbn in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; cbn in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; cbn in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; cbn in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; cbn in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; cbn in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; cbn in T; try discriminate. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. + cbn in T. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. - destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; cbn in T; try discriminate. set (p9 := Renumber.transf_program p8) in *. - destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate. + destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; cbn in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. - destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; cbn in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. set (p13ter := total_if optim_forward_moves ForwardMoves.transf_program p13bis) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13ter) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p13ter) as [p14|e] eqn:P14; cbn in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. + destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; cbn in T; try discriminate. + destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; cbn in T; try discriminate. set (p17 := Tunneling.tunnel_program p16) in *. - destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. + destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; cbn in T; try discriminate. set (p19 := CleanupLabels.transf_program p18) in *. - destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. - destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. + destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; cbn in T; try discriminate. + destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; cbn in T; try discriminate. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. -- cgit From c991b6f67778634cf1c8df5fb429a74d068c8fb8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 22 Apr 2020 11:27:15 +0200 Subject: cbn and copyright --- driver/Compiler.vexpand | 18 +++++++++--------- tools/compiler_expand.ml | 10 ++++++++++ 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/driver/Compiler.vexpand b/driver/Compiler.vexpand index 1e671464..0f59aab7 100644 --- a/driver/Compiler.vexpand +++ b/driver/Compiler.vexpand @@ -208,15 +208,15 @@ Theorem transf_c_program_match: match_prog p tp. Proof. intros p tp T. - unfold transf_c_program, time in T. simpl in T. - destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. - unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. - destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. - destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. - unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. + unfold transf_c_program, time in T. cbn in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; cbn in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; cbn in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; cbn in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; cbn in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; cbn in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; cbn in T; try discriminate. unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. cbn in T. EXPAND_RTL_PROOF diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 4fc746f0..960d1ce1 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -1,3 +1,13 @@ +(* +The Compcert verified compiler + +Compiler.vexpand -> Compiler.v + +Expand the list of RTL compiler passes into Compiler.v + +David Monniaux, CNRS, VERIMAG + *) + type is_partial = TOTAL | PARTIAL;; type print_result = Noprint | Print of string;; type when_triggered = Always | Option of string;; -- cgit From a4e86b9131f39648e6e54f2ae5c498be0c2e5f41 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 22 Apr 2020 11:43:45 +0200 Subject: use cbn not simpl --- driver/Compiler.v | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/driver/Compiler.v b/driver/Compiler.v index e6d39152..17cb67af 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -306,38 +306,38 @@ Theorem transf_c_program_match: match_prog p tp. Proof. intros p tp T. - unfold transf_c_program, time in T. simpl in T. - destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. - unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. - destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. - destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. - unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + unfold transf_c_program, time in T. cbn in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; cbn in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; cbn in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; cbn in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; cbn in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; cbn in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; cbn in T; try discriminate. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. cbn in T. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. - destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; cbn in T; try discriminate. set (p9 := total_if Compopts.optim_move_loop_invariants FirstNop.transf_program p8) in *. set (p9bis := Renumber.transf_program p9) in *. - destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; simpl in T; try discriminate. + destruct (partial_if optim_duplicate Duplicate.transf_program p9bis) as [p10|e] eqn:P10; cbn in T; try discriminate. set (p11 := Renumber.transf_program p10) in *. set (p12 := total_if optim_constprop Constprop.transf_program p11) in *. - destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; simpl in T; try discriminate. + destruct (partial_if optim_move_loop_invariants LICM.transf_program p12) as [p12bis|e] eqn:P12bis; cbn in T; try discriminate. set (p12ter :=(total_if optim_move_loop_invariants Renumber.transf_program p12bis)) in *. - destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_CSE CSE.transf_program p12ter) as [p13|e] eqn:P13; cbn in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. + destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; cbn in T; try discriminate. set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; cbn in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. + destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; cbn in T; try discriminate. + destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; cbn in T; try discriminate. set (p17 := Tunneling.tunnel_program p16) in *. - destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. + destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; cbn in T; try discriminate. set (p19 := CleanupLabels.transf_program p18) in *. - destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. - destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. + destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; cbn in T; try discriminate. + destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; cbn in T; try discriminate. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. -- cgit From 7a30a72809448535785cd47d26d9415f6ada93e3 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 07:25:57 +0200 Subject: make sure phases are aligned --- driver/Clflags.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 6986fb96..467d41aa 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -79,6 +79,6 @@ let option_fglobaladdroffset = ref false let option_fxsaddr = ref true let option_faddx = ref false let option_fcoalesce_mem = ref true -let option_fforward_moves = ref true +let option_fforward_moves = ref false let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 -- cgit From dc43cc3371f7837cff5b8d1fd536aba54e99232f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 09:00:46 +0200 Subject: CSE3analysisaux: pp_rhs --- backend/CSE3analysisaux.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 23e20ea8..0260f3b1 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -37,6 +37,14 @@ let print_set s = List.iter (fun i -> Printf.printf "%d; " (P.to_int i)) (PSet.elements s); Printf.printf "}\n";; +let pp_rhs oc (sop, args) = + match sop with + | SOp op -> PrintOp.print_operation PrintRTL.reg oc (op, args) + | SLoad(chunk, addr) -> + Printf.fprintf oc "%s[%a]" + (PrintAST.name_of_chunk chunk) + (PrintOp.print_addressing PrintRTL.reg) (addr, args);; + let preanalysis (tenv : typing_env) (f : RTL.coq_function) = let cur_eq_id = ref 0 and cur_catalog = ref PTree.empty @@ -48,6 +56,7 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = let eq_find_oracle node eq = Hashtbl.find_opt eq_table (flatten_eq eq) and rhs_find_oracle node sop args = + (* Printf.printf "query for %a\n" pp_rhs (sop, args); *) match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with | None -> PSet.empty | Some s -> s in -- cgit From 69447b8515c0bd123c6aa72c5545cf9beda79ec4 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 11:43:06 +0200 Subject: fix in CSE3 move propagation --- backend/CSE3analysis.v | 19 ++++++++++++++----- backend/CSE3analysisaux.ml | 39 ++++++++++++++++++++++++++++++--------- backend/CSE3analysisproof.v | 26 ++++++++++++++++++-------- driver/Compiler.v | 40 ++++++++++++++++++++-------------------- 4 files changed, 82 insertions(+), 42 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index b495371d..91064a5d 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -274,11 +274,20 @@ Section OPERATIONS. Definition oper (dst : reg) (op: sym_op) (args : list reg) (rel : RELATION.t) : RELATION.t := - match rhs_find op (forward_move_l rel args) rel with - | Some r => RELATION.glb (move r dst rel) - (oper1 dst op args rel) - | None => oper1 dst op args rel - end. + if is_smove op + then + match args with + | src::nil => + move (forward_move rel src) dst rel + | _ => kill_reg dst rel + end + else + let args' := forward_move_l rel args in + match rhs_find op args' rel with + | Some r => (* FIXME RELATION.glb ( *) move r dst rel (* ) + (oper1 dst op args' rel) *) + | None => oper1 dst op args' rel + end. Definition clever_kill_store (chunk : memory_chunk) (addr: addressing) (args : list reg) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 0260f3b1..e8e608da 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -32,10 +32,10 @@ let print_eq channel (lhs, sop, args) = Printf.printf "%a = %s @ %a\n" print_reg lhs (string_of_chunk chunk) (PrintOp.print_addressing print_reg) (addr, args);; -let print_set s = - Printf.printf "{ "; - List.iter (fun i -> Printf.printf "%d; " (P.to_int i)) (PSet.elements s); - Printf.printf "}\n";; +let pp_set oc s = + Printf.fprintf oc "{ "; + List.iter (fun i -> Printf.fprintf oc "%d; " (P.to_int i)) (PSet.elements s); + Printf.fprintf oc "}";; let pp_rhs oc (sop, args) = match sop with @@ -45,6 +45,16 @@ let pp_rhs oc (sop, args) = (PrintAST.name_of_chunk chunk) (PrintOp.print_addressing PrintRTL.reg) (addr, args);; +let pp_eq oc eq = + Printf.fprintf oc "x%d = %a" (P.to_int eq.eq_lhs) + pp_rhs (eq.eq_op, eq.eq_args);; + +let pp_P oc x = Printf.fprintf oc "%d" (P.to_int x) + +let pp_option pp oc = function + | None -> output_string oc "none" + | Some x -> pp oc x;; + let preanalysis (tenv : typing_env) (f : RTL.coq_function) = let cur_eq_id = ref 0 and cur_catalog = ref PTree.empty @@ -54,14 +64,21 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = and cur_kill_mem = ref PSet.empty and cur_moves = ref (PMap.init PSet.empty) in let eq_find_oracle node eq = - Hashtbl.find_opt eq_table (flatten_eq eq) + let o = Hashtbl.find_opt eq_table (flatten_eq eq) in + Printf.printf "@%d: eq_find %a -> %a\n" (P.to_int node) + pp_eq eq (pp_option pp_P) o; + o and rhs_find_oracle node sop args = - (* Printf.printf "query for %a\n" pp_rhs (sop, args); *) - match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with - | None -> PSet.empty - | Some s -> s in + let o = + match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with + | None -> PSet.empty + | Some s -> s in + Printf.printf "@%d: rhs_find %a = %a\n" (P.to_int node) pp_rhs (sop, args) + pp_set o; + o in let mutating_eq_find_oracle node eq : P.t option = let (flat_eq_lhs, flat_eq_op, flat_eq_args) as flat_eq = flatten_eq eq in + let o = match Hashtbl.find_opt eq_table flat_eq with | Some x -> Some x @@ -88,6 +105,10 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = | _, _ -> ()); Some coq_id end + in + Printf.printf "@%d: mutating_eq_find %a -> %a\n" (P.to_int node) + pp_eq eq (pp_option pp_P) o; + o in match internal_analysis diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 3ea5e078..116353fa 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -778,15 +778,25 @@ Section SOUNDNESS. intros until v. intros REL RHS. unfold oper. - destruct rhs_find as [src |] eqn:RHS_FIND. - - apply sem_rel_glb; split. - + pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. - eapply forward_move_rhs_sound in RHS. - 2: eassumption. - rewrite <- (sem_rhs_det SOUND RHS). - apply move_sound; auto. + destruct (is_smove sop). + - subst. + simpl in RHS. + destruct args. contradiction. + destruct args. 2: contradiction. + cbn in *. + subst. + rewrite <- (forward_move_sound rel rs m r) by auto. + apply move_sound; auto. + - destruct rhs_find as [src |] eqn:RHS_FIND. + + (* FIXME apply sem_rel_glb; split. *) + * pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. + eapply forward_move_rhs_sound in RHS. + 2: eassumption. + rewrite <- (sem_rhs_det SOUND RHS). + apply move_sound; auto. + (* FIXME * apply oper1_sound; auto. *) + apply oper1_sound; auto. - - apply oper1_sound; auto. + apply forward_move_rhs_sound; auto. Qed. Hint Resolve oper_sound : cse3. diff --git a/driver/Compiler.v b/driver/Compiler.v index 3dbd35ce..6a799bd7 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -293,35 +293,35 @@ Theorem transf_c_program_match: match_prog p tp. Proof. intros p tp T. - unfold transf_c_program, time in T. simpl in T. - destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. - unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. - destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. - destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. - unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. - destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. - destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. - unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + unfold transf_c_program, time in T. cbn in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; cbn in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; cbn in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; cbn in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; cbn in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. cbn in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; cbn in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; cbn in T; try discriminate. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. cbn in T. set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. - destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; cbn in T; try discriminate. set (p9 := Renumber.transf_program p8) in *. - destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate. + destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; cbn in T; try discriminate. set (p11 := total_if optim_constprop Constprop.transf_program p10) in *. set (p12 := total_if optim_constprop Renumber.transf_program p11) in *. - destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; cbn in T; try discriminate. set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *. - destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; simpl in T; try discriminate. + destruct (partial_if optim_CSE3 CSE3.transf_program p13bis) as [p13ter|e] eqn:P13ter; cbn in T; try discriminate. set (p13quater := total_if optim_forward_moves ForwardMoves.transf_program p13ter) in *. - destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p13quater) as [p14|e] eqn:P14; cbn in T; try discriminate. set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *. - destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate. - destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate. + destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; cbn in T; try discriminate. + destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; cbn in T; try discriminate. set (p17 := Tunneling.tunnel_program p16) in *. - destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate. + destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; cbn in T; try discriminate. set (p19 := CleanupLabels.transf_program p18) in *. - destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. - destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate. + destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; cbn in T; try discriminate. + destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; cbn in T; try discriminate. unfold match_prog; simpl. exists p1; split. apply SimplExprproof.transf_program_match; auto. exists p2; split. apply SimplLocalsproof.match_transf_program; auto. -- cgit From 2316b5dc954b4047f3f48c61e7f4e34deb729efe Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 12:29:38 +0200 Subject: make tracing output optional --- backend/CSE3analysisaux.ml | 15 +++++++++------ driver/Clflags.ml | 1 + driver/Driver.ml | 1 + 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index e8e608da..3f7d5bb9 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -65,16 +65,18 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = and cur_moves = ref (PMap.init PSet.empty) in let eq_find_oracle node eq = let o = Hashtbl.find_opt eq_table (flatten_eq eq) in - Printf.printf "@%d: eq_find %a -> %a\n" (P.to_int node) - pp_eq eq (pp_option pp_P) o; + (if !Clflags.option_debug_compcert > 1 + then Printf.printf "@%d: eq_find %a -> %a\n" (P.to_int node) + pp_eq eq (pp_option pp_P) o); o and rhs_find_oracle node sop args = let o = match Hashtbl.find_opt rhs_table (sop, List.map P.to_int args) with | None -> PSet.empty | Some s -> s in - Printf.printf "@%d: rhs_find %a = %a\n" (P.to_int node) pp_rhs (sop, args) - pp_set o; + (if !Clflags.option_debug_compcert > 1 + then Printf.printf "@%d: rhs_find %a = %a\n" + (P.to_int node) pp_rhs (sop, args) pp_set o); o in let mutating_eq_find_oracle node eq : P.t option = let (flat_eq_lhs, flat_eq_op, flat_eq_args) as flat_eq = flatten_eq eq in @@ -106,8 +108,9 @@ let preanalysis (tenv : typing_env) (f : RTL.coq_function) = Some coq_id end in - Printf.printf "@%d: mutating_eq_find %a -> %a\n" (P.to_int node) - pp_eq eq (pp_option pp_P) o; + (if !Clflags.option_debug_compcert > 1 + then Printf.printf "@%d: mutating_eq_find %a -> %a\n" (P.to_int node) + pp_eq eq (pp_option pp_P) o); o in match diff --git a/driver/Clflags.ml b/driver/Clflags.ml index ff2647a7..a5f5f7a4 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -84,3 +84,4 @@ let option_fcoalesce_mem = ref true let option_fforward_moves = ref true let option_all_loads_nontrap = ref false let option_inline_auto_threshold = ref 0 +let option_debug_compcert = ref 0 diff --git a/driver/Driver.ml b/driver/Driver.ml index b167dbd1..9b873505 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -330,6 +330,7 @@ let cmdline_actions = Exact "-Os", Set option_Osize; Exact "-Obranchless", Set option_Obranchless; Exact "-finline-auto-threshold", Integer (fun n -> option_inline_auto_threshold := n); + Exact "-debug-compcert", Integer (fun n -> option_debug_compcert := n); Exact "-fsmall-data", Integer(fun n -> option_small_data := n); Exact "-fsmall-const", Integer(fun n -> option_small_const := n); Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n); -- cgit From 7b0d7a74ccfaf5843c41e2844e02e94e9a76bfd8 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 14:25:31 +0200 Subject: CSE3 across calls --- backend/CSE3analysis.v | 22 +++++++++++++++++----- backend/CSE3analysisproof.v | 21 ++++++++++++++++----- driver/Clflags.ml | 3 ++- driver/Compopts.v | 5 ++++- driver/Driver.ml | 4 +++- extraction/extraction.v | 2 ++ 6 files changed, 44 insertions(+), 13 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index 91064a5d..ef487c86 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -344,16 +344,28 @@ Section OPERATIONS. Definition apply_external_call ef (rel : RELATION.t) : RELATION.t := match ef with - | EF_builtin name sg - | EF_runtime name sg => + | EF_builtin name sg => match Builtins.lookup_builtin_function name sg with | Some bf => rel - | None => kill_mem rel + | None => if Compopts.optim_CSE3_across_calls tt + then kill_mem rel + else RELATION.top end - | EF_malloc (* FIXME *) + | EF_runtime name sg => + if Compopts.optim_CSE3_across_calls tt + then + match Builtins.lookup_builtin_function name sg with + | Some bf => rel + | None => kill_mem rel + end + else RELATION.top + | EF_malloc | EF_external _ _ + | EF_free => + if Compopts.optim_CSE3_across_calls tt + then kill_mem rel + else RELATION.top | EF_vstore _ - | EF_free (* FIXME *) | EF_memcpy _ _ (* FIXME *) | EF_inline_asm _ _ _ => kill_mem rel | _ => rel diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 116353fa..c65a6d9e 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -917,6 +917,17 @@ Section SOUNDNESS. Hint Resolve kill_builtin_res_sound : cse3. + Lemma top_sound: + forall rs m, (sem_rel RELATION.top rs m). + Proof. + unfold RELATION.top, sem_rel. + intros. + rewrite PSet.gempty in H. + discriminate. + Qed. + + Hint Resolve top_sound : cse3. + Lemma external_call_sound: forall ge ef (rel : RELATION.t) (m m' : mem) (rs : regset) vargs t vres (REL : sem_rel rel rs m) @@ -926,11 +937,11 @@ Section SOUNDNESS. destruct ef; intros; simpl in *. all: eauto using kill_mem_sound. all: unfold builtin_or_external_sem in *. - 1, 2: destruct (Builtins.lookup_builtin_function name sg); - eauto using kill_mem_sound; - inv CALL; eauto using kill_mem_sound. - all: inv CALL. - all: eauto using kill_mem_sound. + 1, 2, 3, 5, 6: destruct (Compopts.optim_CSE3_across_calls tt). + all: eauto using kill_mem_sound, top_sound. + 1, 2, 3: destruct (Builtins.lookup_builtin_function name sg). + all: eauto using kill_mem_sound, top_sound. + all: inv CALL; eauto using kill_mem_sound. Qed. Hint Resolve external_call_sound : cse3. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index b9828f15..9d868de3 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -25,10 +25,11 @@ let option_ffpu = ref true let option_ffloatconstprop = ref 2 let option_ftailcalls = ref true let option_fconstprop = ref true -let option_fcse = ref false +let option_fcse = ref true let option_fcse2 = ref false let option_fcse3 = ref true let option_fcse3_alias_analysis = ref true +let option_fcse3_across_calls = ref false let option_fredundancy = ref true let option_fduplicate = ref (-1) let option_finvertcond = ref true diff --git a/driver/Compopts.v b/driver/Compopts.v index 5acd2640..fb3481e2 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -45,9 +45,12 @@ Parameter optim_CSE2: unit -> bool. (** Flag -fcse3. For DMonniaux's common subexpression elimination. *) Parameter optim_CSE3: unit -> bool. -(** Flag -fcse3-alias-analysis. For DMonniaux's common subexpression elimination. *) +(** Flag -fcse3-alias-analysis. For DMonniaux's common subexpression elimination. Perform a simple alias analysis. *) Parameter optim_CSE3_alias_analysis: unit -> bool. +(** Flag -fcse3-across-calls. For DMonniaux's common subexpression elimination. Propagate information across function calls (may increase register pressure). *) +Parameter optim_CSE3_across_calls: unit -> bool. + (** Flag -fmove-loop-invariants. *) Parameter optim_move_loop_invariants: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index 4e4bab16..ea9af62e 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -195,10 +195,11 @@ Processing options: -fconst-prop Perform global constant propagation [on] -ffloat-const-prop Control constant propagation of floats (=0: none, =1: limited, =2: full; default is full) - -fcse Perform common subexpression elimination [off] + -fcse Perform common subexpression elimination [on] -fcse2 Perform inter-loop common subexpression elimination [off] -fcse3 Perform inter-loop common subexpression elimination [on] -fcse3-alias-analysis Perform inter-loop common subexpression elimination with alias analysis [on] + -fcse3-across-calls Propagate CSE3 information across function calls [off] -fmove-loop-invariants Perform loop-invariant code motion [off] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] @@ -403,6 +404,7 @@ let cmdline_actions = @ f_opt "cse2" option_fcse2 @ f_opt "cse3" option_fcse3 @ f_opt "cse3-alias-analysis" option_fcse3_alias_analysis + @ f_opt "cse3-across-calls" option_fcse3_across_calls @ f_opt "move-loop-invariants" option_fmove_loop_invariants @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass diff --git a/extraction/extraction.v b/extraction/extraction.v index b6aa3409..fc906631 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -123,6 +123,8 @@ Extract Constant Compopts.optim_CSE3 => "fun _ -> !Clflags.option_fcse3". Extract Constant Compopts.optim_CSE3_alias_analysis => "fun _ -> !Clflags.option_fcse3_alias_analysis". +Extract Constant Compopts.optim_CSE3_across_calls => + "fun _ -> !Clflags.option_fcse3_across_calls". Extract Constant Compopts.optim_move_loop_invariants => "fun _ -> !Clflags.option_fmove_loop_invariants". -- cgit From ce36b497e2af67f09bb98247e03d0d7a1fe6216f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 23 Apr 2020 16:57:18 +0200 Subject: sync with licm --- tools/compiler_expand.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 960d1ce1..025dbacc 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -24,7 +24,7 @@ PARTIAL, (Option "optim_duplicate"), (Some "Tail-duplicating"), "Duplicate"; TOTAL, Always, (Some "Renumbering pre constprop"), "Renumber"; TOTAL, (Option "optim_constprop"), (Some "Constant propagation"), "Constprop"; PARTIAL, (Option "optim_move_loop_invariants"), (Some "LICM"), "LICM"; -TOTAL, (Option "optim_move_loop_invariants"), (Some "Renumbering pre CSE"), "Renumber"; +TOTAL, Always, (Some "Renumbering pre CSE"), "Renumber"; PARTIAL, (Option "optim_CSE"), (Some "CSE"), "CSE"; TOTAL, (Option "optim_CSE2"), (Some "CSE2"), "CSE2"; PARTIAL, (Option "optim_CSE3"), (Some "CSE3"), "CSE3"; -- cgit From fd81859f8a8299b4f3d399d605175ff1b8ee2a81 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Fri, 24 Apr 2020 09:07:57 +0200 Subject: run a separate CSE3 for LICM --- tools/compiler_expand.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 025dbacc..8738c3af 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -23,13 +23,15 @@ TOTAL, Always, (Some "Renumbering"), "Renumber"; PARTIAL, (Option "optim_duplicate"), (Some "Tail-duplicating"), "Duplicate"; TOTAL, Always, (Some "Renumbering pre constprop"), "Renumber"; TOTAL, (Option "optim_constprop"), (Some "Constant propagation"), "Constprop"; -PARTIAL, (Option "optim_move_loop_invariants"), (Some "LICM"), "LICM"; TOTAL, Always, (Some "Renumbering pre CSE"), "Renumber"; PARTIAL, (Option "optim_CSE"), (Some "CSE"), "CSE"; TOTAL, (Option "optim_CSE2"), (Some "CSE2"), "CSE2"; PARTIAL, (Option "optim_CSE3"), (Some "CSE3"), "CSE3"; TOTAL, (Option "optim_forward_moves"), (Some "Forwarding moves"), "ForwardMoves"; PARTIAL, (Option "optim_redundancy"), (Some "Redundancy elimination"), "Deadcode"; +PARTIAL, (Option "optim_move_loop_invariants"), (Some "LICM"), "LICM"; +PARTIAL, (Option "optim_move_loop_invariants"), (Some "CSE3 for LICM"), "CSE3"; +PARTIAL, (Option "optim_move_loop_invariants"), (Some "Redundancy elimination for LICM"), "Deadcode"; TOTAL, (Option "all_loads_nontrap"), None, "Allnontrap"; PARTIAL, Always, (Some "Unused globals"), "Unusedglob" |];; -- cgit From cb7f9dae1d354bbf94d8da87e3d4c72057992965 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Thu, 30 Apr 2020 22:41:22 +0200 Subject: add a renumber phase --- tools/compiler_expand.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/compiler_expand.ml b/tools/compiler_expand.ml index 8738c3af..1fa5ad28 100644 --- a/tools/compiler_expand.ml +++ b/tools/compiler_expand.ml @@ -30,6 +30,7 @@ PARTIAL, (Option "optim_CSE3"), (Some "CSE3"), "CSE3"; TOTAL, (Option "optim_forward_moves"), (Some "Forwarding moves"), "ForwardMoves"; PARTIAL, (Option "optim_redundancy"), (Some "Redundancy elimination"), "Deadcode"; PARTIAL, (Option "optim_move_loop_invariants"), (Some "LICM"), "LICM"; +TOTAL, (Option "optim_move_loop_invariants"), (Some "Renumbering for LICM"), "Renumber"; PARTIAL, (Option "optim_move_loop_invariants"), (Some "CSE3 for LICM"), "CSE3"; PARTIAL, (Option "optim_move_loop_invariants"), (Some "Redundancy elimination for LICM"), "Deadcode"; TOTAL, (Option "all_loads_nontrap"), None, "Allnontrap"; -- cgit From 4f6c5833a149d0659f4bffaaeb464cd9864b3a9b Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 May 2020 13:12:39 +0200 Subject: Update on testsuite and INSTALL.md --- INSTALL.md | 17 ++++++++++------- test/mppa/simucheck.sh | 4 +++- test/mppa/simutest.sh | 4 +++- 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index bcfec78f..256bfa4e 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,14 +1,16 @@ # CompCert Install Instructions ## Dependencies + ### Additional dependencies + Replace with the package manager for your distribution ``` -sudo install -y mercurial darcs ocaml - +sudo install -y mercurial darcs ocaml bubblewrap ``` ### Opam + ``` sh <(curl -sL https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh) ``` @@ -20,20 +22,21 @@ eval `opam config env` ``` Add this to your `.bashrc` or `.bash_profile` ``` -. /nfs/home/mschuh/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true +. $HOME/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true ``` -Switch to last compiler version +Switch to a recent OCaml compiler version ``` -opam switch 4.07.0 +opam switch create 4.09.0 +opam switch 4.09.0 ``` -Install dependecies available through opam +Install dependencies available through opam ``` opam install coq menhir ``` ## Compilation Pre-compilation configure replace the placeholder with your desired platform -(for Kalray it is k1c-cos or k1c-mbr) +(for Kalray Coolidge it is `k1c-cos`) ``` ./configure ``` diff --git a/test/mppa/simucheck.sh b/test/mppa/simucheck.sh index 25fb9947..48698e35 100755 --- a/test/mppa/simucheck.sh +++ b/test/mppa/simucheck.sh @@ -1,6 +1,8 @@ #!/bin/bash # Tests the execution of the binaries produced by CompCert, by simulation +cores=$(grep -c ^processor /proc/cpuinfo) + source do_test.sh -do_test check $1 +do_test check $cores diff --git a/test/mppa/simutest.sh b/test/mppa/simutest.sh index 3b1021e6..729d1ba0 100755 --- a/test/mppa/simutest.sh +++ b/test/mppa/simutest.sh @@ -1,6 +1,8 @@ #!/bin/bash # Tests the validity of the tests, in simulator +cores=$(grep -c ^processor /proc/cpuinfo) + source do_test.sh -do_test test $1 +do_test test $cores -- cgit From c22a1828063756fdc11876993e6f1e2ca3bba04d Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 May 2020 16:35:45 +0200 Subject: Adding copyrights --- aarch64/CSE2deps.v | 12 +++++++++++ aarch64/CSE2depsproof.v | 12 +++++++++++ aarch64/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ arm/CSE2deps.v | 12 +++++++++++ arm/CSE2depsproof.v | 12 +++++++++++ arm/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ backend/Allnontrap.v | 12 +++++++++++ backend/Allnontrapproof.v | 12 +++++++++++ backend/Asmaux.v | 16 +++++++++++++- backend/CSE2.v | 12 +++++++++++ backend/CSE2proof.v | 12 +++++++++++ backend/CSE3.v | 12 +++++++++++ backend/CSE3analysis.v | 12 +++++++++++ backend/CSE3analysisaux.ml | 12 +++++++++++ backend/CSE3analysisproof.v | 11 ++++++++++ backend/CSE3proof.v | 12 +++++++++++ backend/Duplicate.v | 14 ++++++++++++ backend/Duplicateaux.ml | 14 ++++++++++++ backend/Duplicateproof.v | 14 ++++++++++++ backend/FirstNop.v | 12 +++++++++++ backend/FirstNopproof.v | 12 +++++++++++ backend/ForwardMoves.v | 12 +++++++++++ backend/ForwardMovesproof.v | 12 +++++++++++ backend/Inject.v | 12 +++++++++++ backend/Injectproof.v | 12 +++++++++++ backend/LICM.v | 12 +++++++++++ backend/LICMaux.ml | 12 +++++++++++ backend/LICMproof.v | 12 +++++++++++ backend/Linearizeaux.ml | 2 +- backend/OpHelpers.v | 12 +++++++++++ backend/OpHelpersproof.v | 14 +++++++++++- backend/Profiling.v | 12 +++++++++++ backend/ProfilingExploit.v | 12 +++++++++++ backend/ProfilingExploitproof.v | 12 +++++++++++ backend/Profilingaux.ml | 12 +++++++++++ backend/Profilingproof.v | 12 +++++++++++ lib/HashedSet.v | 12 +++++++++++ lib/HashedSetaux.ml | 12 +++++++++++ lib/HashedSetaux.mli | 12 +++++++++++ lib/extra/HashedMap.v | 12 +++++++++++ mppa_k1c/Archi.v | 31 +++++++++++++-------------- mppa_k1c/Asm.v | 30 ++++++++++++-------------- mppa_k1c/Asmaux.v | 14 ++++++++++++ mppa_k1c/Asmblock.v | 29 +++++++++++-------------- mppa_k1c/Asmblockdeps.v | 14 ++++++++++++ mppa_k1c/Asmblockgen.v | 30 ++++++++++++-------------- mppa_k1c/Asmblockgenproof.v | 25 ++++++++++++---------- mppa_k1c/Asmblockgenproof1.v | 30 ++++++++++++-------------- mppa_k1c/Asmblockprops.v | 14 ++++++++++++ mppa_k1c/Asmexpand.ml | 31 ++++++++++++--------------- mppa_k1c/Asmgen.v | 30 ++++++++++++-------------- mppa_k1c/Asmgenproof.v | 25 ++++++++++++---------- mppa_k1c/Asmvliw.v | 30 ++++++++++++-------------- mppa_k1c/Builtins1.v | 28 ++++++++++++------------ mppa_k1c/CBuiltins.ml | 28 ++++++++++++------------ mppa_k1c/CSE2deps.v | 12 +++++++++++ mppa_k1c/CSE2depsproof.v | 12 +++++++++++ mppa_k1c/Chunks.v | 14 ++++++++++++ mppa_k1c/CombineOp.v | 25 ++++++++++++---------- mppa_k1c/CombineOpproof.v | 25 ++++++++++++---------- mppa_k1c/ConstpropOp.vp | 25 ++++++++++++---------- mppa_k1c/ConstpropOpproof.v | 25 ++++++++++++---------- mppa_k1c/Conventions1.v | 30 ++++++++++++-------------- mppa_k1c/DecBoolOps.v | 17 ++++++++++++++- mppa_k1c/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ mppa_k1c/ExtFloats.v | 15 +++++++++++++ mppa_k1c/ExtValues.v | 15 +++++++++++++ mppa_k1c/InstructionScheduler.ml | 14 ++++++++++++ mppa_k1c/Machregs.v | 30 ++++++++++++-------------- mppa_k1c/Machregsaux.ml | 25 ++++++++++++---------- mppa_k1c/NeedOp.v | 30 ++++++++++++-------------- mppa_k1c/Op.v | 30 ++++++++++++-------------- mppa_k1c/Peephole.v | 14 ++++++++++++ mppa_k1c/PostpassScheduling.v | 24 +++++++++++---------- mppa_k1c/PostpassSchedulingOracle.ml | 14 ++++++++++++ mppa_k1c/PostpassSchedulingproof.v | 24 +++++++++++---------- mppa_k1c/PrintOp.ml | 30 ++++++++++++-------------- mppa_k1c/SelectLong.vp | 32 +++++++++++++--------------- mppa_k1c/SelectLongproof.v | 30 ++++++++++++-------------- mppa_k1c/SelectOp.vp | 30 ++++++++++++-------------- mppa_k1c/SelectOpproof.v | 30 ++++++++++++-------------- mppa_k1c/Stacklayout.v | 25 ++++++++++++---------- mppa_k1c/TargetPrinter.ml | 30 ++++++++++++-------------- mppa_k1c/ValueAOp.v | 25 ++++++++++++---------- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 14 ++++++++++++ mppa_k1c/abstractbb/ImpSimuTest.v | 12 +++++++++++ mppa_k1c/abstractbb/Impure/ImpConfig.v | 2 +- mppa_k1c/abstractbb/Impure/ImpCore.v | 2 +- mppa_k1c/abstractbb/Parallelizability.v | 14 ++++++++++++ mppa_k1c/abstractbb/SeqSimuTheory.v | 12 +++++++++++ mppa_k1c/extractionMachdep.v | 28 ++++++++++++------------ mppa_k1c/lib/Asmblockgenproof0.v | 15 +++++++++++++ mppa_k1c/lib/ForwardSimulationBlock.v | 14 ++++++++++++ mppa_k1c/lib/Machblock.v | 14 ++++++++++++ mppa_k1c/lib/Machblockgen.v | 14 ++++++++++++ mppa_k1c/lib/Machblockgenproof.v | 16 +++++++++++++- powerpc/CSE2deps.v | 12 +++++++++++ powerpc/CSE2depsproof.v | 12 +++++++++++ powerpc/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ riscV/CSE2deps.v | 12 +++++++++++ riscV/CSE2depsproof.v | 12 +++++++++++ riscV/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ runtime/c/write_profiling_table.c | 12 +++++++++++ runtime/include/ccomp_k1c_fixes.h | 15 +++++++++++++ runtime/include/math.h | 14 ++++++++++++ x86/CSE2deps.v | 12 +++++++++++ x86/CSE2depsproof.v | 12 +++++++++++ x86/DuplicateOpcodeHeuristic.ml | 14 ++++++++++++ 108 files changed, 1392 insertions(+), 460 deletions(-) diff --git a/aarch64/CSE2deps.v b/aarch64/CSE2deps.v index 90b514a2..a23e41a8 100644 --- a/aarch64/CSE2deps.v +++ b/aarch64/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/aarch64/CSE2depsproof.v b/aarch64/CSE2depsproof.v index 4aac23af..dbd46142 100644 --- a/aarch64/CSE2depsproof.v +++ b/aarch64/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/aarch64/DuplicateOpcodeHeuristic.ml b/aarch64/DuplicateOpcodeHeuristic.ml index 5fc2156c..3a3b87fc 100644 --- a/aarch64/DuplicateOpcodeHeuristic.ml +++ b/aarch64/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open Op open Integers diff --git a/arm/CSE2deps.v b/arm/CSE2deps.v index 9db51bbb..d48dabf3 100644 --- a/arm/CSE2deps.v +++ b/arm/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/arm/CSE2depsproof.v b/arm/CSE2depsproof.v index 61fe5980..28ef41ca 100644 --- a/arm/CSE2depsproof.v +++ b/arm/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/arm/DuplicateOpcodeHeuristic.ml b/arm/DuplicateOpcodeHeuristic.ml index 9b6a6409..41996028 100644 --- a/arm/DuplicateOpcodeHeuristic.ml +++ b/arm/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open Op open Integers diff --git a/backend/Allnontrap.v b/backend/Allnontrap.v index acf03eca..fedf14f7 100644 --- a/backend/Allnontrap.v +++ b/backend/Allnontrap.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/Allnontrapproof.v b/backend/Allnontrapproof.v index 92e5a88c..157c5de2 100644 --- a/backend/Allnontrapproof.v +++ b/backend/Allnontrapproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import FunInd. Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. diff --git a/backend/Asmaux.v b/backend/Asmaux.v index 51e94f6b..1167c34c 100644 --- a/backend/Asmaux.v +++ b/backend/Asmaux.v @@ -1,5 +1,19 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Asm. Require Import AST. (* Constant only needed by Asmexpandaux.ml *) -Definition dummy_function := {| fn_code := nil; fn_sig := signature_main |}. \ No newline at end of file +Definition dummy_function := {| fn_code := nil; fn_sig := signature_main |}. diff --git a/backend/CSE2.v b/backend/CSE2.v index 00b1821e..3042645e 100644 --- a/backend/CSE2.v +++ b/backend/CSE2.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* Replace available expressions by the register containing their value. diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v index f9c7b400..49dbd409 100644 --- a/backend/CSE2proof.v +++ b/backend/CSE2proof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* Replace available expressions by the register containing their value. diff --git a/backend/CSE3.v b/backend/CSE3.v index 2203ad14..df1c2bfc 100644 --- a/backend/CSE3.v +++ b/backend/CSE3.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps CSE2deps. diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index ef487c86..b5fdbd63 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps CSE2deps. diff --git a/backend/CSE3analysisaux.ml b/backend/CSE3analysisaux.ml index 3f7d5bb9..3e4a6b9e 100644 --- a/backend/CSE3analysisaux.ml +++ b/backend/CSE3analysisaux.ml @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open CSE3analysis open Maps open HashedSet diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index c65a6d9e..0c2aeb8e 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -1,3 +1,14 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. diff --git a/backend/CSE3proof.v b/backend/CSE3proof.v index ccbfd198..6e489066 100644 --- a/backend/CSE3proof.v +++ b/backend/CSE3proof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* Replace available expressions by the register containing their value. diff --git a/backend/Duplicate.v b/backend/Duplicate.v index af85efe4..0e04b07d 100644 --- a/backend/Duplicate.v +++ b/backend/Duplicate.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** RTL node duplication using external oracle. Used to form superblock structures *) diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml index 89f187da..00819834 100644 --- a/backend/Duplicateaux.ml +++ b/backend/Duplicateaux.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* Oracle for Duplicate pass. * - Add static prediction information to Icond nodes * - Performs tail duplication on interesting traces to form superblocks diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v index 6b598dc7..62455076 100644 --- a/backend/Duplicateproof.v +++ b/backend/Duplicateproof.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Correctness proof for code duplication *) Require Import AST Linking Errors Globalenvs Smallstep. Require Import Coqlib Maps Events Values. diff --git a/backend/FirstNop.v b/backend/FirstNop.v index f7e5261e..b3c765e4 100644 --- a/backend/FirstNop.v +++ b/backend/FirstNop.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/FirstNopproof.v b/backend/FirstNopproof.v index a5d63c25..5a1c5acf 100644 --- a/backend/FirstNopproof.v +++ b/backend/FirstNopproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Values Memory Globalenvs Events Smallstep. diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v index 7cfd411f..1b375532 100644 --- a/backend/ForwardMoves.v +++ b/backend/ForwardMoves.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v index 826d4250..f3e572e0 100644 --- a/backend/ForwardMovesproof.v +++ b/backend/ForwardMovesproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import FunInd. Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. diff --git a/backend/Inject.v b/backend/Inject.v index 971a5423..a24fef50 100644 --- a/backend/Inject.v +++ b/backend/Inject.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/Injectproof.v b/backend/Injectproof.v index 75fed25f..dd5e72f8 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Globalenvs Values Events. diff --git a/backend/LICM.v b/backend/LICM.v index 0a0a1c7d..787ce256 100644 --- a/backend/LICM.v +++ b/backend/LICM.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/LICMaux.ml b/backend/LICMaux.ml index 4ebc7844..c3907809 100644 --- a/backend/LICMaux.ml +++ b/backend/LICMaux.ml @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open RTL;; open Camlcoq;; open Maps;; diff --git a/backend/LICMproof.v b/backend/LICMproof.v index 2b76b668..e3f0c2b8 100644 --- a/backend/LICMproof.v +++ b/backend/LICMproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml index 9d5a5ba6..3f1a8b6e 100644 --- a/backend/Linearizeaux.ml +++ b/backend/Linearizeaux.ml @@ -1,4 +1,4 @@ - +(* *********************************************************************) (* *) (* The Compcert verified compiler *) (* *) diff --git a/backend/OpHelpers.v b/backend/OpHelpers.v index b9b97903..7f8af39b 100644 --- a/backend/OpHelpers.v +++ b/backend/OpHelpers.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import AST Integers Floats. Require Import Op CminorSel. diff --git a/backend/OpHelpersproof.v b/backend/OpHelpersproof.v index 08da8a36..63199520 100644 --- a/backend/OpHelpersproof.v +++ b/backend/OpHelpersproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Maps. Require Import AST. @@ -75,4 +87,4 @@ Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) /\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i /\ helper_declared p f32_div "__compcert_f32_div" sig_ss_s /\ helper_declared p f64_div "__compcert_f64_div" sig_ff_f -. \ No newline at end of file +. diff --git a/backend/Profiling.v b/backend/Profiling.v index 4cba49ee..83e96311 100644 --- a/backend/Profiling.v +++ b/backend/Profiling.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/ProfilingExploit.v b/backend/ProfilingExploit.v index cfca1a12..2325f582 100644 --- a/backend/ProfilingExploit.v +++ b/backend/ProfilingExploit.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL. diff --git a/backend/ProfilingExploitproof.v b/backend/ProfilingExploitproof.v index bc68c38e..78de09af 100644 --- a/backend/ProfilingExploitproof.v +++ b/backend/ProfilingExploitproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import FunInd. Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. diff --git a/backend/Profilingaux.ml b/backend/Profilingaux.ml index ec0ae304..6ecea9e6 100644 --- a/backend/Profilingaux.ml +++ b/backend/Profilingaux.ml @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open Camlcoq open RTL open Maps diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index fc04c77e..abb86bdb 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Values Memory Globalenvs Events Smallstep. diff --git a/lib/HashedSet.v b/lib/HashedSet.v index 00e01612..cb2ee1b2 100644 --- a/lib/HashedSet.v +++ b/lib/HashedSet.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import ZArith. Require Import Bool. Require Import List. diff --git a/lib/HashedSetaux.ml b/lib/HashedSetaux.ml index 8329c249..501475d6 100644 --- a/lib/HashedSetaux.ml +++ b/lib/HashedSetaux.ml @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + type uid = int let uid_base = min_int diff --git a/lib/HashedSetaux.mli b/lib/HashedSetaux.mli index 14beac41..e3426eb4 100644 --- a/lib/HashedSetaux.mli +++ b/lib/HashedSetaux.mli @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + type pset val qnode : pset -> bool -> pset -> pset val node : pset * bool * pset -> pset diff --git a/lib/extra/HashedMap.v b/lib/extra/HashedMap.v index df724867..a7d6f589 100644 --- a/lib/extra/HashedMap.v +++ b/lib/extra/HashedMap.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import ZArith. Require Import Bool. Require Import List. diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v index 587f768e..1a15b733 100644 --- a/mppa_k1c/Archi.v +++ b/mppa_k1c/Archi.v @@ -1,18 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* Jacques-Henri Jourdan, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) @@ -33,7 +32,7 @@ Proof. unfold splitlong. congruence. Qed. -(** THIS IS NOT CHECKED ! NONE OF THIS ! *) +(** FIXME - Check the properties below *) (** Section 7.3: "Except when otherwise stated, if the result of a floating-point operation is NaN, it is the canonical NaN. The diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v index 189e0c76..c8c0bc1c 100644 --- a/mppa_k1c/Asm.v +++ b/mppa_k1c/Asm.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** * Abstract syntax for K1c textual assembly language. diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v index 891d1068..2abd445e 100644 --- a/mppa_k1c/Asmaux.v +++ b/mppa_k1c/Asmaux.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Asm. Require Import AST. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v index a05d4726..885ac6bc 100644 --- a/mppa_k1c/Asmblock.v +++ b/mppa_k1c/Asmblock.v @@ -1,19 +1,16 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Sequential block semantics for K1c assembly. The syntax is given in AsmVLIW *) diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v index 01eda623..1881e7e9 100644 --- a/mppa_k1c/Asmblockdeps.v +++ b/mppa_k1c/Asmblockdeps.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** * Translation from Asmblock to AbstractBB We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v index 36269954..f57b596b 100644 --- a/mppa_k1c/Asmblockgen.v +++ b/mppa_k1c/Asmblockgen.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** * Translation from Machblock to K1c assembly language (Asmblock) Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *) diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v index 1a427112..5cb498bc 100644 --- a/mppa_k1c/Asmblockgenproof.v +++ b/mppa_k1c/Asmblockgenproof.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Correctness proof for RISC-V generation: main proof. *) diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v index 9c836037..74b9b62b 100644 --- a/mppa_k1c/Asmblockgenproof1.v +++ b/mppa_k1c/Asmblockgenproof1.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** * Proof of correctness for individual instructions *) diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v index 3c6ba534..bc14b231 100644 --- a/mppa_k1c/Asmblockprops.v +++ b/mppa_k1c/Asmblockprops.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Common definition and proofs on Asmblock required by various modules *) Require Import Coqlib. diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml index e388d2aa..785887b2 100644 --- a/mppa_k1c/Asmexpand.ml +++ b/mppa_k1c/Asmexpand.ml @@ -1,20 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (* Expanding built-ins and some pseudo-instructions by rewriting of the RISC-V assembly code. *) diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v index 8875a4ac..61856acf 100644 --- a/mppa_k1c/Asmgen.v +++ b/mppa_k1c/Asmgen.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Integers. Require Import Mach Asm Asmblock Asmblockgen Machblockgen. diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v index 7388f6da..f43acd37 100644 --- a/mppa_k1c/Asmgenproof.v +++ b/mppa_k1c/Asmgenproof.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Correctness proof for Asmgen *) diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v index 819120a0..b085fb1d 100644 --- a/mppa_k1c/Asmvliw.v +++ b/mppa_k1c/Asmvliw.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Abstract syntax and semantics for VLIW semantics of K1c assembly language. *) diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v index 3b5cd419..eeb578d0 100644 --- a/mppa_k1c/Builtins1.v +++ b/mppa_k1c/Builtins1.v @@ -1,17 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, Collège de France and Inria Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Platform-specific built-in functions *) diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml index a91119b1..6dc3e938 100644 --- a/mppa_k1c/CBuiltins.ml +++ b/mppa_k1c/CBuiltins.ml @@ -1,17 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (* Processor-dependent builtin C functions *) diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v index 8ab9242a..b4b80e2f 100644 --- a/mppa_k1c/CSE2deps.v +++ b/mppa_k1c/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v index a3811e78..f283c8ac 100644 --- a/mppa_k1c/CSE2depsproof.v +++ b/mppa_k1c/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/mppa_k1c/Chunks.v b/mppa_k1c/Chunks.v index 40778877..86d4f0ac 100644 --- a/mppa_k1c/Chunks.v +++ b/mppa_k1c/Chunks.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import AST. Require Import Values. Require Import Integers. diff --git a/mppa_k1c/CombineOp.v b/mppa_k1c/CombineOp.v index 6236f38f..ff1db3cd 100644 --- a/mppa_k1c/CombineOp.v +++ b/mppa_k1c/CombineOp.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Recognition of combined operations, addressing modes and conditions during the [CSE] phase. *) diff --git a/mppa_k1c/CombineOpproof.v b/mppa_k1c/CombineOpproof.v index a24de1e5..dafc90df 100644 --- a/mppa_k1c/CombineOpproof.v +++ b/mppa_k1c/CombineOpproof.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Recognition of combined operations, addressing modes and conditions during the [CSE] phase. *) diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp index 7ee3dfe8..2a428020 100644 --- a/mppa_k1c/ConstpropOp.vp +++ b/mppa_k1c/ConstpropOp.vp @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Strength reduction for operators and conditions. This is the machine-dependent part of [Constprop]. *) diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v index 4dd0441d..05bbdde1 100644 --- a/mppa_k1c/ConstpropOpproof.v +++ b/mppa_k1c/ConstpropOpproof.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Correctness proof for operator strength reduction. *) diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v index 48346a6d..ab30ded9 100644 --- a/mppa_k1c/Conventions1.v +++ b/mppa_k1c/Conventions1.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Function calling conventions and other conventions regarding the use of machine registers and stack slots. *) diff --git a/mppa_k1c/DecBoolOps.v b/mppa_k1c/DecBoolOps.v index 7f6f7c87..1e0a6187 100644 --- a/mppa_k1c/DecBoolOps.v +++ b/mppa_k1c/DecBoolOps.v @@ -1,3 +1,18 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Set Implicit Arguments. Theorem and_dec : forall A B C D : Prop, @@ -12,4 +27,4 @@ Proof. - right. tauto. Qed. - \ No newline at end of file + diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml index 2ec314c1..38702e1b 100644 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* open Camlcoq *) open Op open Integers diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v index d9b9d3a6..9849c35d 100644 --- a/mppa_k1c/ExtFloats.v +++ b/mppa_k1c/ExtFloats.v @@ -1,3 +1,18 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Floats Integers ZArith. Module ExtFloat. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v index 5a890f3c..3664c00a 100644 --- a/mppa_k1c/ExtValues.v +++ b/mppa_k1c/ExtValues.v @@ -1,3 +1,18 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Integers. Require Import Values. diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml index 9d3503e2..e4dc3f97 100644 --- a/mppa_k1c/InstructionScheduler.ml +++ b/mppa_k1c/InstructionScheduler.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Schedule instructions on a synchronized pipeline @author David Monniaux, CNRS, VERIMAG *) diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v index cff1164c..a242fce2 100644 --- a/mppa_k1c/Machregs.v +++ b/mppa_k1c/Machregs.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import String. Require Import Coqlib. diff --git a/mppa_k1c/Machregsaux.ml b/mppa_k1c/Machregsaux.ml index 9c4175ed..76956959 100644 --- a/mppa_k1c/Machregsaux.ml +++ b/mppa_k1c/Machregsaux.ml @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Auxiliary functions on machine registers *) diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v index 7111c48b..4c354d5a 100644 --- a/mppa_k1c/NeedOp.v +++ b/mppa_k1c/NeedOp.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib. Require Import AST Integers Floats. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v index 012d67d0..544bb081 100644 --- a/mppa_k1c/Op.v +++ b/mppa_k1c/Op.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Operators and addressing modes. The abstract syntax and dynamic semantics for the CminorSel, RTL, LTL and Mach languages depend on the diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v index 0611fdda..35f4bbd9 100644 --- a/mppa_k1c/Peephole.v +++ b/mppa_k1c/Peephole.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Asmvliw. Require Import Values. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v index 31180cea..7518866d 100644 --- a/mppa_k1c/PostpassScheduling.v +++ b/mppa_k1c/PostpassScheduling.v @@ -1,14 +1,16 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib Errors AST Integers. Require Import Asmblock Axioms Memory Globalenvs. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml index 686979a6..325f70e5 100644 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ b/mppa_k1c/PostpassSchedulingOracle.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + open Asmvliw open Asmblock open Printf diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v index 8cc7f0ab..c290387b 100644 --- a/mppa_k1c/PostpassSchedulingproof.v +++ b/mppa_k1c/PostpassSchedulingproof.v @@ -1,14 +1,16 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib Errors. Require Import Integers Floats AST Linking. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml index 67f87000..da7d6c32 100644 --- a/mppa_k1c/PrintOp.ml +++ b/mppa_k1c/PrintOp.ml @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Pretty-printing of operators, conditions, addressing modes *) diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp index 981c796c..b3638eca 100644 --- a/mppa_k1c/SelectLong.vp +++ b/mppa_k1c/SelectLong.vp @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Instruction selection for 64-bit integer operations *) @@ -462,4 +460,4 @@ End SELECT. (* Local Variables: *) (* mode: coq *) -(* End: *) \ No newline at end of file +(* End: *) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v index 5e4f3ed6..fb38bbce 100644 --- a/mppa_k1c/SelectLongproof.v +++ b/mppa_k1c/SelectLongproof.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Correctness of instruction selection for 64-bit integer operations *) diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp index bd481cbb..9e5d45a0 100644 --- a/mppa_k1c/SelectOp.vp +++ b/mppa_k1c/SelectOp.vp @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Instruction selection for operators *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v index 28294934..d1d0b95c 100644 --- a/mppa_k1c/SelectOpproof.v +++ b/mppa_k1c/SelectOpproof.v @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Correctness of instruction selection for operators *) diff --git a/mppa_k1c/Stacklayout.v b/mppa_k1c/Stacklayout.v index d0c6a526..46202e03 100644 --- a/mppa_k1c/Stacklayout.v +++ b/mppa_k1c/Stacklayout.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (** Machine- and ABI-dependent layout information for activation records. *) diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml index 01751f19..e85b5ef3 100644 --- a/mppa_k1c/TargetPrinter.ml +++ b/mppa_k1c/TargetPrinter.ml @@ -1,19 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Prashanth Mundkur, SRI International *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* The contributions by Prashanth Mundkur are reused and adapted *) -(* under the terms of a Contributor License Agreement between *) -(* SRI International and INRIA. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (* Printing RISC-V assembly code in asm syntax *) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v index 901908b5..e634fdc0 100644 --- a/mppa_k1c/ValueAOp.v +++ b/mppa_k1c/ValueAOp.v @@ -1,14 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) Require Import Coqlib Compopts. Require Import AST Integers Floats Values Memory Globalenvs. diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v index cf46072f..0b1c502d 100644 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Syntax and Sequential Semantics of Abstract Basic Blocks. *) Require Import Setoid. diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v index 7a77ec15..c914eee1 100644 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ b/mppa_k1c/abstractbb/ImpSimuTest.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks with imperative hash-consing, and rewriting. diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v index e49a4611..dd9785b5 100644 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v @@ -82,4 +82,4 @@ Extract Inlined Constant bind => "(|>)". Extract Constant t "" => "". (* This weird directive extracts [t] as "'a" instead of "'a t" *) Extraction Inline t. -Global Opaque t. \ No newline at end of file +Global Opaque t. diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v index f1abaf7a..508b3f19 100644 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ b/mppa_k1c/abstractbb/Impure/ImpCore.v @@ -193,4 +193,4 @@ Ltac wlp_xsimplify hint := Create HintDb wlp discriminated. -Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). \ No newline at end of file +Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v index 30904b5d..feebeee5 100644 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ b/mppa_k1c/abstractbb/Parallelizability.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** Parallel Semantics of Abstract Basic Blocks and parallelizability test. *) diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v index e234883f..61f8f2ec 100644 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ b/mppa_k1c/abstractbb/SeqSimuTheory.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** A theory for checking/proving simulation by symbolic execution. *) diff --git a/mppa_k1c/extractionMachdep.v b/mppa_k1c/extractionMachdep.v index fdecd2a3..2e409931 100644 --- a/mppa_k1c/extractionMachdep.v +++ b/mppa_k1c/extractionMachdep.v @@ -1,17 +1,17 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) (* Additional extraction directives specific to the RISC-V port *) diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v index 58455ada..1af59238 100644 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ b/mppa_k1c/lib/Asmblockgenproof0.v @@ -1,3 +1,18 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (** * "block" version of Asmgenproof0 This module is largely adapted from Asmgenproof0.v of the other backends diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v index 224eda0a..f79814f2 100644 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ b/mppa_k1c/lib/ForwardSimulationBlock.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (*** Auxiliary lemmas on starN and forward_simulation diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v index 5a7f1782..08e0eba2 100644 --- a/mppa_k1c/lib/Machblock.v +++ b/mppa_k1c/lib/Machblock.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Maps. Require Import AST. diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v index 2ba42814..287e4f7b 100644 --- a/mppa_k1c/lib/Machblockgen.v +++ b/mppa_k1c/lib/Machblockgen.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Maps. Require Import AST. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v index 0de2df52..dfb97bfe 100644 --- a/mppa_k1c/lib/Machblockgenproof.v +++ b/mppa_k1c/lib/Machblockgenproof.v @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib. Require Import Maps. Require Import AST. @@ -807,4 +821,4 @@ Proof. eapply ra_exists; eauto. Qed. -End Mach_Return_Address. \ No newline at end of file +End Mach_Return_Address. diff --git a/powerpc/CSE2deps.v b/powerpc/CSE2deps.v index 9db51bbb..d48dabf3 100644 --- a/powerpc/CSE2deps.v +++ b/powerpc/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v index fdded9b6..123341da 100644 --- a/powerpc/CSE2depsproof.v +++ b/powerpc/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/powerpc/DuplicateOpcodeHeuristic.ml b/powerpc/DuplicateOpcodeHeuristic.ml index 33be79e8..c48fdfba 100644 --- a/powerpc/DuplicateOpcodeHeuristic.ml +++ b/powerpc/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* open Camlcoq *) open Op open Integers diff --git a/riscV/CSE2deps.v b/riscV/CSE2deps.v index 8ab9242a..b4b80e2f 100644 --- a/riscV/CSE2deps.v +++ b/riscV/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v index a3811e78..f283c8ac 100644 --- a/riscV/CSE2depsproof.v +++ b/riscV/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/riscV/DuplicateOpcodeHeuristic.ml b/riscV/DuplicateOpcodeHeuristic.ml index 2ec314c1..38702e1b 100644 --- a/riscV/DuplicateOpcodeHeuristic.ml +++ b/riscV/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* open Camlcoq *) open Op open Integers diff --git a/runtime/c/write_profiling_table.c b/runtime/c/write_profiling_table.c index 0ce7a948..f8f46306 100644 --- a/runtime/c/write_profiling_table.c +++ b/runtime/c/write_profiling_table.c @@ -1,3 +1,15 @@ +/* *************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* David Monniaux CNRS, VERIMAG */ +/* */ +/* Copyright VERIMAG. All rights reserved. */ +/* This file is distributed under the terms of the INRIA */ +/* Non-Commercial License Agreement. */ +/* */ +/* *************************************************************/ + #include #include #include diff --git a/runtime/include/ccomp_k1c_fixes.h b/runtime/include/ccomp_k1c_fixes.h index 7f111742..c884ae23 100644 --- a/runtime/include/ccomp_k1c_fixes.h +++ b/runtime/include/ccomp_k1c_fixes.h @@ -1,3 +1,18 @@ +/* *************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* Sylvain Boulmé Grenoble-INP, VERIMAG */ +/* David Monniaux CNRS, VERIMAG */ +/* Cyril Six Kalray */ +/* */ +/* Copyright Kalray. Copyright VERIMAG. All rights reserved. */ +/* This file is distributed under the terms of the INRIA */ +/* Non-Commercial License Agreement. */ +/* */ +/* *************************************************************/ + + #ifndef __CCOMP_KIC_FIXES_H #define __CCOMP_KIC_FIXES_H diff --git a/runtime/include/math.h b/runtime/include/math.h index 01b8d8d8..422787e1 100644 --- a/runtime/include/math.h +++ b/runtime/include/math.h @@ -1,3 +1,17 @@ +/* *************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* Sylvain Boulmé Grenoble-INP, VERIMAG */ +/* David Monniaux CNRS, VERIMAG */ +/* Cyril Six Kalray */ +/* */ +/* Copyright Kalray. Copyright VERIMAG. All rights reserved. */ +/* This file is distributed under the terms of the INRIA */ +/* Non-Commercial License Agreement. */ +/* */ +/* *************************************************************/ + #ifndef _COMPCERT_MATH_H #define _COMPCERT_MATH_H diff --git a/x86/CSE2deps.v b/x86/CSE2deps.v index f4d9e254..a4b47a5c 100644 --- a/x86/CSE2deps.v +++ b/x86/CSE2deps.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import BoolEqual Coqlib. Require Import AST Integers Floats. Require Import Values Memory Globalenvs Events. diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v index 1e913254..fd088962 100644 --- a/x86/CSE2depsproof.v +++ b/x86/CSE2depsproof.v @@ -1,3 +1,15 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. Require Import AST Linking. Require Import Memory Registers Op RTL Maps. diff --git a/x86/DuplicateOpcodeHeuristic.ml b/x86/DuplicateOpcodeHeuristic.ml index 2ec314c1..38702e1b 100644 --- a/x86/DuplicateOpcodeHeuristic.ml +++ b/x86/DuplicateOpcodeHeuristic.ml @@ -1,3 +1,17 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + (* open Camlcoq *) open Op open Integers -- cgit From 9bb82668364d31dfff19b1d926fb5aebabae7a31 Mon Sep 17 00:00:00 2001 From: Cyril SIX Date: Mon, 4 May 2020 16:35:59 +0200 Subject: README Kalray --- README_Kalray.md | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) create mode 100644 README_Kalray.md diff --git a/README_Kalray.md b/README_Kalray.md new file mode 100644 index 00000000..7516daa6 --- /dev/null +++ b/README_Kalray.md @@ -0,0 +1,32 @@ +# CompCert Kalray port +The verified C compiler ported to Kalray. + +## Features + +This delivery contains (in addition to features from CompCert master branch): +- A fully functional port of CompCert to Coolidge k1c VLIW core +- Postpass scheduling optimization, only for k1c. Activated by default, it can be deactivated with the compiler flag `-fno-postpass` +- Some experimental features that are work in progress: + - Slightly better subexpression eliminations, called CSE2 and CSE3. Both go through loops and feature a small alias analysis. + - `-fduplicate 0` to activate static branch prediction information. The branch prediction is basic, it annotates each `Icond` node by an `option bool`. A `Some true` annotation indicates we predict the branch will be taken. `Some false` indicates the fallthrough case is predicted. `None` indicates we could not predict anything, and are not sure about which control will be preferred. + - It is also possible to provide a number to perform tail duplication: `-fduplicate 5` will tail duplicate, stopping when more than 5 RTL instructions have been duplicated. This feature offers very variable performance (from -20% up to +20%) because of variations in the later register allocation phase that impacts the postpass scheduling. We intend to work on fine tuning the tail duplication phase once we have the prepass superblock scheduling. + - `-ftracelinearize` uses the branch prediction information to linearize LTL basic blocks in a slightly better way (in the `Linearize` phase). + +## Installing + +Please follow the instructions in `INSTALL.md` + +## Testing + +We modified most of the CompCert tests of the `c` folder in order for them to be executable in reasonable time by the simulator. + +To pass the testsuite, first, build and install CompCert using the instructions in `INSTALL.md`, then: +``` +cd test/c +make +make test +``` + +The reference files were generated using `k1-cos-gcc -O1`. + +We also have our own tests in `test/mppa/` - to run them, execute the script `simucheck.sh` located in that folder. These consist in comparing `compcert` output to `k1-cos-gcc` output. -- cgit From b679621ac631ac2783bfd391042d30c120b5a220 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 6 May 2020 14:13:33 +0200 Subject: make Aarch64 muladd depend on the option --- aarch64/SelectOp.vp | 8 ++++++-- aarch64/SelectOpproof.v | 6 ++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/aarch64/SelectOp.vp b/aarch64/SelectOp.vp index f9e5a1c4..67575fdb 100644 --- a/aarch64/SelectOp.vp +++ b/aarch64/SelectOp.vp @@ -56,9 +56,13 @@ Nondetfunction add (e1: expr) (e2: expr) := | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s => Eop (Oaddshift s a) (t1 ::: t2 ::: Enil) | Eop Omul (t1:::t2:::Enil), t3 => - Eop Omuladd (t3:::t1:::t2:::Enil) + if Compopts.optim_madd tt + then Eop Omuladd (t3:::t1:::t2:::Enil) + else Eop Oadd (e1:::e2:::Enil) | t1, Eop Omul (t2:::t3:::Enil) => - Eop Omuladd (t1:::t2:::t3:::Enil) + if Compopts.optim_madd tt + then Eop Omuladd (t1:::t2:::t3:::Enil) + else Eop Oadd (e1:::e2:::Enil) | _, _ => Eop Oadd (e1:::e2:::Enil) end. diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v index 54c6a9fd..3379cbd8 100644 --- a/aarch64/SelectOpproof.v +++ b/aarch64/SelectOpproof.v @@ -161,8 +161,10 @@ Proof. - rewrite <- Val.add_assoc. apply eval_addimm. EvalOp. - rewrite Val.add_commut. TrivialExists. - TrivialExists. -- rewrite Val.add_commut. TrivialExists. -- TrivialExists. +- destruct (Compopts.optim_madd tt). + + rewrite Val.add_commut. TrivialExists. + + TrivialExists. +- destruct (Compopts.optim_madd tt); TrivialExists. - TrivialExists. Qed. -- cgit From f1f535cad98f3db3e586f0f7a2dbc329fc5bff6f Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 6 May 2020 20:16:08 +0200 Subject: CSE3 across merges --- backend/CSE3analysis.v | 36 +++++++++++++++++++++++++----------- driver/Clflags.ml | 1 + driver/Compopts.v | 3 +++ driver/Driver.ml | 2 ++ extraction/extraction.v | 2 ++ 5 files changed, 33 insertions(+), 11 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index b5fdbd63..bd507dec 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -75,29 +75,43 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. intuition. Qed. - Definition lub := PSet.inter. + Definition lub x y := + if Compopts.optim_CSE3_across_merges tt + then PSet.inter x y + else PSet.empty. + Definition glb := PSet.union. Lemma ge_lub_left: forall x y, ge (lub x y) x. Proof. unfold ge, lub. intros. - apply PSet.is_subset_spec. - intro. - rewrite PSet.ginter. - rewrite andb_true_iff. - intuition. + destruct (Compopts.optim_CSE3_across_merges tt). + - apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + - apply PSet.is_subset_spec. + intro. + rewrite PSet.gempty. + discriminate. Qed. Lemma ge_lub_right: forall x y, ge (lub x y) y. Proof. unfold ge, lub. intros. - apply PSet.is_subset_spec. - intro. - rewrite PSet.ginter. - rewrite andb_true_iff. - intuition. + destruct (Compopts.optim_CSE3_across_merges tt). + - apply PSet.is_subset_spec. + intro. + rewrite PSet.ginter. + rewrite andb_true_iff. + intuition. + - apply PSet.is_subset_spec. + intro. + rewrite PSet.gempty. + discriminate. Qed. Definition top := PSet.empty. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index 14d15ba6..d84a546d 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -30,6 +30,7 @@ let option_fcse2 = ref false let option_fcse3 = ref true let option_fcse3_alias_analysis = ref true let option_fcse3_across_calls = ref false +let option_fcse3_across_merges = ref true let option_fredundancy = ref true let option_fduplicate = ref (-1) let option_finvertcond = ref true diff --git a/driver/Compopts.v b/driver/Compopts.v index 3c5ccf36..445f5793 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -51,6 +51,9 @@ Parameter optim_CSE3_alias_analysis: unit -> bool. (** Flag -fcse3-across-calls. For DMonniaux's common subexpression elimination. Propagate information across function calls (may increase register pressure). *) Parameter optim_CSE3_across_calls: unit -> bool. +(** Flag -fcse3-across-calls. For DMonniaux's common subexpression elimination. Propagate information across control-flow merges (may increase register pressure). *) +Parameter optim_CSE3_across_merges: unit -> bool. + (** Flag -fmove-loop-invariants. *) Parameter optim_move_loop_invariants: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index b9060ca7..9d1caa9e 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -200,6 +200,7 @@ Processing options: -fcse3 Perform inter-loop common subexpression elimination [on] -fcse3-alias-analysis Perform inter-loop common subexpression elimination with alias analysis [on] -fcse3-across-calls Propagate CSE3 information across function calls [off] + -fcse3-across-merges Propagate CSE3 information across control-flow merges [on] -fmove-loop-invariants Perform loop-invariant code motion [off] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] @@ -413,6 +414,7 @@ let cmdline_actions = @ f_opt "cse3" option_fcse3 @ f_opt "cse3-alias-analysis" option_fcse3_alias_analysis @ f_opt "cse3-across-calls" option_fcse3_across_calls + @ f_opt "cse3-across-merges" option_fcse3_across_merges @ f_opt "move-loop-invariants" option_fmove_loop_invariants @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass diff --git a/extraction/extraction.v b/extraction/extraction.v index b40d444a..a7772224 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -125,6 +125,8 @@ Extract Constant Compopts.optim_CSE3_alias_analysis => "fun _ -> !Clflags.option_fcse3_alias_analysis". Extract Constant Compopts.optim_CSE3_across_calls => "fun _ -> !Clflags.option_fcse3_across_calls". +Extract Constant Compopts.optim_CSE3_across_merges => + "fun _ -> !Clflags.option_fcse3_across_merges". Extract Constant Compopts.optim_move_loop_invariants => "fun _ -> !Clflags.option_fmove_loop_invariants". -- cgit From 6171f6a0880acbf0d007a7715cc37984ac25d851 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 6 May 2020 22:33:02 +0200 Subject: -fcse3-glb --- backend/CSE3analysis.v | 24 +++++++++++++++++------- backend/CSE3analysisproof.v | 18 +++++++++++------- driver/Clflags.ml | 1 + driver/Compopts.v | 3 +++ driver/Driver.ml | 2 ++ extraction/extraction.v | 2 ++ 6 files changed, 36 insertions(+), 14 deletions(-) diff --git a/backend/CSE3analysis.v b/backend/CSE3analysis.v index bd507dec..ade79c28 100644 --- a/backend/CSE3analysis.v +++ b/backend/CSE3analysis.v @@ -78,7 +78,10 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. Definition lub x y := if Compopts.optim_CSE3_across_merges tt then PSet.inter x y - else PSet.empty. + else + if PSet.eq x y + then x + else PSet.empty. Definition glb := PSet.union. @@ -94,8 +97,10 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. intuition. - apply PSet.is_subset_spec. intro. - rewrite PSet.gempty. - discriminate. + destruct (PSet.eq x y). + + auto. + + rewrite PSet.gempty. + discriminate. Qed. Lemma ge_lub_right: forall x y, ge (lub x y) y. @@ -110,8 +115,10 @@ Module RELATION <: SEMILATTICE_WITHOUT_BOTTOM. intuition. - apply PSet.is_subset_spec. intro. - rewrite PSet.gempty. - discriminate. + destruct (PSet.eq x y). + + subst. auto. + + rewrite PSet.gempty. + discriminate. Qed. Definition top := PSet.empty. @@ -310,8 +317,11 @@ Section OPERATIONS. else let args' := forward_move_l rel args in match rhs_find op args' rel with - | Some r => (* FIXME RELATION.glb ( *) move r dst rel (* ) - (oper1 dst op args' rel) *) + | Some r => + if Compopts.optim_CSE3_glb tt + then RELATION.glb (move r dst rel) + (oper1 dst op args' rel) + else oper1 dst op args' rel | None => oper1 dst op args' rel end. diff --git a/backend/CSE3analysisproof.v b/backend/CSE3analysisproof.v index 0c2aeb8e..f4e3672d 100644 --- a/backend/CSE3analysisproof.v +++ b/backend/CSE3analysisproof.v @@ -799,13 +799,17 @@ Section SOUNDNESS. rewrite <- (forward_move_sound rel rs m r) by auto. apply move_sound; auto. - destruct rhs_find as [src |] eqn:RHS_FIND. - + (* FIXME apply sem_rel_glb; split. *) - * pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. - eapply forward_move_rhs_sound in RHS. - 2: eassumption. - rewrite <- (sem_rhs_det SOUND RHS). - apply move_sound; auto. - (* FIXME * apply oper1_sound; auto. *) + + destruct (Compopts.optim_CSE3_glb tt). + * apply sem_rel_glb; split. + ** pose proof (rhs_find_sound no sop (forward_move_l (ctx:=ctx) rel args) rel src rs m REL RHS_FIND) as SOUND. + eapply forward_move_rhs_sound in RHS. + 2: eassumption. + rewrite <- (sem_rhs_det SOUND RHS). + apply move_sound; auto. + ** apply oper1_sound; auto. + apply forward_move_rhs_sound; auto. + * ** apply oper1_sound; auto. + apply forward_move_rhs_sound; auto. + apply oper1_sound; auto. apply forward_move_rhs_sound; auto. Qed. diff --git a/driver/Clflags.ml b/driver/Clflags.ml index d84a546d..b0d3740e 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -31,6 +31,7 @@ let option_fcse3 = ref true let option_fcse3_alias_analysis = ref true let option_fcse3_across_calls = ref false let option_fcse3_across_merges = ref true +let option_fcse3_glb = ref true let option_fredundancy = ref true let option_fduplicate = ref (-1) let option_finvertcond = ref true diff --git a/driver/Compopts.v b/driver/Compopts.v index 445f5793..d576ede6 100644 --- a/driver/Compopts.v +++ b/driver/Compopts.v @@ -54,6 +54,9 @@ Parameter optim_CSE3_across_calls: unit -> bool. (** Flag -fcse3-across-calls. For DMonniaux's common subexpression elimination. Propagate information across control-flow merges (may increase register pressure). *) Parameter optim_CSE3_across_merges: unit -> bool. +(** Flag -fcse3-glb *) +Parameter optim_CSE3_glb: unit -> bool. + (** Flag -fmove-loop-invariants. *) Parameter optim_move_loop_invariants: unit -> bool. diff --git a/driver/Driver.ml b/driver/Driver.ml index 9d1caa9e..90afb812 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -201,6 +201,7 @@ Processing options: -fcse3-alias-analysis Perform inter-loop common subexpression elimination with alias analysis [on] -fcse3-across-calls Propagate CSE3 information across function calls [off] -fcse3-across-merges Propagate CSE3 information across control-flow merges [on] + -fcse3-glb Refine CSE3 information using greatest lower bounds [on] -fmove-loop-invariants Perform loop-invariant code motion [off] -fredundancy Perform redundancy elimination [on] -fpostpass Perform postpass scheduling (only for K1 architecture) [on] @@ -415,6 +416,7 @@ let cmdline_actions = @ f_opt "cse3-alias-analysis" option_fcse3_alias_analysis @ f_opt "cse3-across-calls" option_fcse3_across_calls @ f_opt "cse3-across-merges" option_fcse3_across_merges + @ f_opt "cse3-glb" option_fcse3_glb @ f_opt "move-loop-invariants" option_fmove_loop_invariants @ f_opt "redundancy" option_fredundancy @ f_opt "postpass" option_fpostpass diff --git a/extraction/extraction.v b/extraction/extraction.v index a7772224..e43594fc 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -127,6 +127,8 @@ Extract Constant Compopts.optim_CSE3_across_calls => "fun _ -> !Clflags.option_fcse3_across_calls". Extract Constant Compopts.optim_CSE3_across_merges => "fun _ -> !Clflags.option_fcse3_across_merges". +Extract Constant Compopts.optim_CSE3_glb => + "fun _ -> !Clflags.option_fcse3_glb". Extract Constant Compopts.optim_move_loop_invariants => "fun _ -> !Clflags.option_fmove_loop_invariants". -- cgit From afefcbe84bfe603a7954fc99688636e40bfd1c1f Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Sun, 10 May 2020 18:11:58 +0200 Subject: updating the html index for mppa-k1c NOTE: This file has been copied from the one of pldi-artefact branch. --- doc/index-mppa_k1c.html | 72 +++++++++++++++++++------------------------------ 1 file changed, 27 insertions(+), 45 deletions(-) diff --git a/doc/index-mppa_k1c.html b/doc/index-mppa_k1c.html index 41a44a0d..50e11def 100644 --- a/doc/index-mppa_k1c.html +++ b/doc/index-mppa_k1c.html @@ -22,50 +22,19 @@ a:active {color : Red; text-decoration : underline; } -

The CompCert verified compiler

+

The CompCert verified compiler

Commented Coq development

-

Version 3.5, 2019-02-27

-

PATCHED FOR MPPA-K1C

+

Version 3.7, 2020-03-31

+

PATCHED for the Kalray MPPA-K1C VLIW CORE

Introduction

-

CompCert is a compiler that generates PowerPC, ARM, RISC-V and x86 assembly -code from CompCert C, a large subset of the C programming language. -The particularity of this compiler is that it is written mostly within -the specification language of the Coq proof assistant, and its -correctness --- the fact that the generated assembly code is -semantically equivalent to its source program --- was entirely proved -within the Coq proof assistant.

+

This web page is a patched version of the table of contents of the official CompCert documentation, + as given on the CompCert Web site. + The unmodified parts of this table appear in gray. + -

High-level descriptions of the CompCert compiler and its proof of -correctness can be found in the following papers (in increasing order of technical details):

- - -

This Web site gives a commented listing of the underlying Coq -specifications and proofs. Proof scripts are folded by default, but -can be viewed by clicking on "Proof". Some modules (written in italics below) differ between the four target architectures. The -PowerPC versions of these modules are shown below; the ARM, x86 and RISC-V -versions can be found in the source distribution. -

- -

This development is a work in progress; some parts have -substantially changed since the overview papers above were -written.

- -

The complete sources for CompCert can be downloaded from -the CompCert Web site.

- -

This document and the CompCert sources are copyright Institut -National de Recherche en Informatique et en Automatique (INRIA) and -AbsInt Angewandte Informatik GmbH, and are distributed under the terms of the -following license. -

- -

Table of contents

+

Table of contents

General-purpose libraries, data structures and algorithms

@@ -83,8 +52,16 @@ semi-lattices. inequations by fixpoint iteration.
  • UnionFind: a persistent union-find data structure.
  • Postorder: postorder numbering of a directed graph. + + +

    The abstractbb library, introduced for MPPA-K1C

    +
      +
    • AbstractBasicBlocksDef: an IR for verifying some semantic properties on basic-blocks. +
    • Parallelizability: verifying that sequential and parallel semantics are equivalent for a given abstract basic-block. +
    • ImpSimuTest: verifying that a given abstract basic-block is simulated by another one for sequential semantics. This module refines SeqSimuTheory with hash-consing.
    +

    Definitions and theorems used in many parts of the development

      @@ -136,6 +113,10 @@ locations) and Machregs Mach: like Linear, with a more concrete view of the activation record. +
    +
    +

    Languages introduced for MPPA-K1C

    +
    • Machblock: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step). This IR is generic over the processor, even if currently, only used for MPPA_K1C.
    • Asmvliw: abstract syntax and semantics for Mppa_K1c VLIW assembly: atomic instructions are grouped by "bundles". These bundles are executed sequentially, but execution is parallel within bundles. @@ -144,9 +125,9 @@ This IR is generic over the processor, even if currently, only used for MPPA_K1C
    • Asm: a variant of Asmvliw with a flat syntax for bundles, instead of a structured one (bundle termination is encoded as a pseudo-instruction). This IR is mainly a wrapper of Asmvliw for a smooth integration in CompCert (and an easier pretty-printing of the abstract syntax).
    -

    Compiler passes

    +

    Compiler passes

    - +
    @@ -305,7 +286,10 @@ This IR is generic over the processor, even if currently, only used for MPPA_K1C +
    Pass Source & targetStackingproof
    Separation
    +

    Compilation passes introduced for MPPA-K1C

    + @@ -339,6 +323,7 @@ This IR is generic over the processor, even if currently, only used for MPPA_K1C
    Reconstruction of basic-blocks at Mach level Mach to Machblock
    +

    All together

    - -
    -
    Xavier.Leroy@inria.fr
    -
    +
    -- cgit From d804ec4db20717c68c2c8e8f53e804b425d62b90 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 11 May 2020 06:40:34 +0200 Subject: fix index-mppa_k1c.html --- doc/index-mppa_k1c.html | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/index-mppa_k1c.html b/doc/index-mppa_k1c.html index 50e11def..86fd4166 100644 --- a/doc/index-mppa_k1c.html +++ b/doc/index-mppa_k1c.html @@ -302,7 +302,7 @@ This IR is generic over the processor, even if currently, only used for MPPA_K1C Emission of purely sequential assembly code Machblock to Asmblock Asmblockgen - Asmblockgenproof0
    + Asmblockgenproof0
    Asmblockgenproof1
    Asmblockgenproof -- cgit From 490a6caea1a95cfdbddf7aca244fa6a1c83aa9a2 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Mon, 11 May 2020 06:41:38 +0200 Subject: backport to coq 8.10.2 --- backend/Injectproof.v | 8 ++++---- backend/Profilingproof.v | 5 +++++ 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/backend/Injectproof.v b/backend/Injectproof.v index dd5e72f8..9e5ad6df 100644 --- a/backend/Injectproof.v +++ b/backend/Injectproof.v @@ -89,7 +89,7 @@ Qed. Obligation 2. Proof. simpl in BOUND. - lia. + omega. Qed. Program Definition bounded_nth_S_statement : Prop := @@ -104,14 +104,14 @@ Lemma bounded_nth_proof_irr : (BOUND1 BOUND2 : (k < List.length l)%nat), (bounded_nth k l BOUND1) = (bounded_nth k l BOUND2). Proof. - induction k; destruct l; simpl; intros; trivial; lia. + induction k; destruct l; simpl; intros; trivial; omega. Qed. Lemma bounded_nth_S : bounded_nth_S_statement. Proof. unfold bounded_nth_S_statement. induction k; destruct l; simpl; intros; trivial. - 1, 2: lia. + 1, 2: omega. apply bounded_nth_proof_irr. Qed. @@ -121,7 +121,7 @@ Lemma inject_list_injected: Some (inject_instr (bounded_nth k l BOUND) (Pos.succ (pos_add_nat pc k))). Proof. induction l; simpl; intros. - - lia. + - omega. - simpl. destruct k as [ | k]; simpl pos_add_nat. + simpl bounded_nth. diff --git a/backend/Profilingproof.v b/backend/Profilingproof.v index abb86bdb..0cebc601 100644 --- a/backend/Profilingproof.v +++ b/backend/Profilingproof.v @@ -112,6 +112,11 @@ Lemma inject_profiling_call_increases: Proof. intros. simpl. + rewrite <- (Pos2Nat.id (Pos.succ (Pos.succ extra_pc))). + rewrite <- (Pos2Nat.id (extra_pc + 2)). + rewrite !Pos2Nat.inj_succ. + rewrite !Pos2Nat.inj_add. + apply f_equal. lia. Qed. -- cgit From b4a08d0815342b6238d307864f0823d0f07bb691 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 May 2020 22:04:20 +0200 Subject: k1c -> kvx changes --- .gitignore | 16 +- .gitlab-ci.yml | 26 +- INSTALL.md | 4 +- Makefile.extr | 2 +- PROFILING.md | 4 +- README_Kalray.md | 4 +- backend/Selectionaux.ml | 2 +- config_k1c.sh | 1 - config_kvx.sh | 1 + configure | 28 +- cparser/Machine.ml | 4 +- cparser/Machine.mli | 2 +- doc/index-kvx.html | 362 +++ doc/index-mppa_k1c.html | 362 --- driver/Clflags.ml | 2 +- driver/Configuration.ml | 2 +- driver/Frontend.ml | 2 +- kvx/Archi.v | 80 + kvx/Asm.v | 751 ++++++ kvx/AsmToJSON.ml | 23 + kvx/Asmaux.v | 19 + kvx/Asmblock.v | 393 +++ kvx/Asmblockdeps.v | 1833 ++++++++++++++ kvx/Asmblockgen.v | 1217 ++++++++++ kvx/Asmblockgenproof.v | 1807 ++++++++++++++ kvx/Asmblockgenproof1.v | 2499 ++++++++++++++++++++ kvx/Asmblockprops.v | 357 +++ kvx/Asmexpand.ml | 636 +++++ kvx/Asmgen.v | 41 + kvx/Asmgenproof.v | 95 + kvx/Asmvliw.v | 1812 ++++++++++++++ kvx/Builtins1.v | 66 + kvx/CBuiltins.ml | 143 ++ kvx/CSE2deps.v | 32 + kvx/CSE2depsproof.v | 139 ++ kvx/Chunks.v | 36 + kvx/CombineOp.v | 141 ++ kvx/CombineOpproof.v | 176 ++ kvx/ConstpropOp.vp | 312 +++ kvx/ConstpropOpproof.v | 748 ++++++ kvx/Conventions1.v | 418 ++++ kvx/DecBoolOps.v | 30 + kvx/DuplicateOpcodeHeuristic.ml | 41 + kvx/ExtFloats.v | 54 + kvx/ExtValues.v | 755 ++++++ kvx/InstructionScheduler.ml | 1247 ++++++++++ kvx/InstructionScheduler.mli | 110 + kvx/Machregs.v | 245 ++ kvx/Machregsaux.ml | 41 + kvx/Machregsaux.mli | 20 + kvx/NeedOp.v | 414 ++++ kvx/Op.v | 1975 ++++++++++++++++ kvx/Peephole.v | 158 ++ kvx/PostpassScheduling.v | 530 +++++ kvx/PostpassSchedulingOracle.ml | 1029 ++++++++ kvx/PostpassSchedulingproof.v | 689 ++++++ kvx/PrintOp.ml | 229 ++ kvx/SelectLong.vp | 463 ++++ kvx/SelectLongproof.v | 950 ++++++++ kvx/SelectOp.vp | 715 ++++++ kvx/SelectOpproof.v | 1735 ++++++++++++++ kvx/Stacklayout.v | 150 ++ kvx/TargetPrinter.ml | 887 +++++++ kvx/ValueAOp.v | 884 +++++++ kvx/abstractbb/AbstractBasicBlocksDef.v | 452 ++++ kvx/abstractbb/ImpSimuTest.v | 1258 ++++++++++ kvx/abstractbb/Impure/ImpConfig.v | 85 + kvx/abstractbb/Impure/ImpCore.v | 196 ++ kvx/abstractbb/Impure/ImpExtern.v | 7 + kvx/abstractbb/Impure/ImpHCons.v | 199 ++ kvx/abstractbb/Impure/ImpIO.v | 159 ++ kvx/abstractbb/Impure/ImpLoops.v | 123 + kvx/abstractbb/Impure/ImpMonads.v | 148 ++ kvx/abstractbb/Impure/ImpPrelude.v | 206 ++ kvx/abstractbb/Impure/LICENSE | 165 ++ kvx/abstractbb/Impure/README.md | 31 + kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml | 66 + kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli | 5 + kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml | 142 ++ kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli | 33 + kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml | 78 + kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli | 8 + kvx/abstractbb/Parallelizability.v | 793 +++++++ kvx/abstractbb/README.md | 12 + kvx/abstractbb/SeqSimuTheory.v | 396 ++++ kvx/bitmasks.py | 12 + kvx/extractionMachdep.v | 32 + kvx/lib/Asmblockgenproof0.v | 982 ++++++++ kvx/lib/ForwardSimulationBlock.v | 387 +++ kvx/lib/Machblock.v | 380 +++ kvx/lib/Machblockgen.v | 216 ++ kvx/lib/Machblockgenproof.v | 824 +++++++ kvx/unittest/Makefile | 13 + kvx/unittest/postpass_test.ml | 12 + mppa_k1c/Archi.v | 80 - mppa_k1c/Asm.v | 751 ------ mppa_k1c/AsmToJSON.ml | 23 - mppa_k1c/Asmaux.v | 19 - mppa_k1c/Asmblock.v | 393 --- mppa_k1c/Asmblockdeps.v | 1833 -------------- mppa_k1c/Asmblockgen.v | 1217 ---------- mppa_k1c/Asmblockgenproof.v | 1807 -------------- mppa_k1c/Asmblockgenproof1.v | 2499 -------------------- mppa_k1c/Asmblockprops.v | 357 --- mppa_k1c/Asmexpand.ml | 636 ----- mppa_k1c/Asmgen.v | 41 - mppa_k1c/Asmgenproof.v | 95 - mppa_k1c/Asmvliw.v | 1812 -------------- mppa_k1c/Builtins1.v | 66 - mppa_k1c/CBuiltins.ml | 143 -- mppa_k1c/CSE2deps.v | 32 - mppa_k1c/CSE2depsproof.v | 139 -- mppa_k1c/Chunks.v | 36 - mppa_k1c/CombineOp.v | 141 -- mppa_k1c/CombineOpproof.v | 176 -- mppa_k1c/ConstpropOp.vp | 312 --- mppa_k1c/ConstpropOpproof.v | 748 ------ mppa_k1c/Conventions1.v | 418 ---- mppa_k1c/DecBoolOps.v | 30 - mppa_k1c/DuplicateOpcodeHeuristic.ml | 41 - mppa_k1c/ExtFloats.v | 54 - mppa_k1c/ExtValues.v | 755 ------ mppa_k1c/InstructionScheduler.ml | 1247 ---------- mppa_k1c/InstructionScheduler.mli | 110 - mppa_k1c/Machregs.v | 245 -- mppa_k1c/Machregsaux.ml | 41 - mppa_k1c/Machregsaux.mli | 20 - mppa_k1c/NeedOp.v | 414 ---- mppa_k1c/Op.v | 1975 ---------------- mppa_k1c/Peephole.v | 158 -- mppa_k1c/PostpassScheduling.v | 530 ----- mppa_k1c/PostpassSchedulingOracle.ml | 1029 -------- mppa_k1c/PostpassSchedulingproof.v | 689 ------ mppa_k1c/PrintOp.ml | 229 -- mppa_k1c/SelectLong.vp | 463 ---- mppa_k1c/SelectLongproof.v | 950 -------- mppa_k1c/SelectOp.vp | 715 ------ mppa_k1c/SelectOpproof.v | 1735 -------------- mppa_k1c/Stacklayout.v | 150 -- mppa_k1c/TargetPrinter.ml | 887 ------- mppa_k1c/ValueAOp.v | 884 ------- mppa_k1c/abstractbb/AbstractBasicBlocksDef.v | 452 ---- mppa_k1c/abstractbb/ImpSimuTest.v | 1258 ---------- mppa_k1c/abstractbb/Impure/ImpConfig.v | 85 - mppa_k1c/abstractbb/Impure/ImpCore.v | 196 -- mppa_k1c/abstractbb/Impure/ImpExtern.v | 7 - mppa_k1c/abstractbb/Impure/ImpHCons.v | 199 -- mppa_k1c/abstractbb/Impure/ImpIO.v | 159 -- mppa_k1c/abstractbb/Impure/ImpLoops.v | 123 - mppa_k1c/abstractbb/Impure/ImpMonads.v | 148 -- mppa_k1c/abstractbb/Impure/ImpPrelude.v | 206 -- mppa_k1c/abstractbb/Impure/LICENSE | 165 -- mppa_k1c/abstractbb/Impure/README.md | 31 - .../abstractbb/Impure/ocaml/ImpHConsOracles.ml | 66 - .../abstractbb/Impure/ocaml/ImpHConsOracles.mli | 5 - mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml | 142 -- mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli | 33 - mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml | 78 - .../abstractbb/Impure/ocaml/ImpLoopOracles.mli | 8 - mppa_k1c/abstractbb/Parallelizability.v | 793 ------- mppa_k1c/abstractbb/README.md | 12 - mppa_k1c/abstractbb/SeqSimuTheory.v | 396 ---- mppa_k1c/bitmasks.py | 12 - mppa_k1c/extractionMachdep.v | 32 - mppa_k1c/lib/Asmblockgenproof0.v | 982 -------- mppa_k1c/lib/ForwardSimulationBlock.v | 387 --- mppa_k1c/lib/Machblock.v | 380 --- mppa_k1c/lib/Machblockgen.v | 216 -- mppa_k1c/lib/Machblockgenproof.v | 824 ------- mppa_k1c/unittest/Makefile | 13 - mppa_k1c/unittest/postpass_test.ml | 12 - runtime/Makefile | 8 +- runtime/c/ccomp_k1c_fixes.h | 1 - runtime/c/ccomp_kvx_fixes.h | 1 + runtime/include/ccomp_k1c_fixes.h | 45 - runtime/include/ccomp_kvx_fixes.h | 45 + runtime/include/math.h | 2 +- runtime/kvx/Makefile | 15 + runtime/kvx/ccomp_k1c_fixes.h | 1 + runtime/kvx/i32_divmod.s | 120 + runtime/kvx/i64_sdiv.c | 23 + runtime/kvx/i64_smod.c | 5 + runtime/kvx/i64_udiv.c | 6 + runtime/kvx/i64_udivmod.c | 30 + runtime/kvx/i64_udivmod_stsud.s | 218 ++ runtime/kvx/i64_umod.c | 6 + runtime/kvx/vararg.s | 54 + runtime/mppa_k1c/Makefile | 15 - runtime/mppa_k1c/ccomp_k1c_fixes.h | 1 - runtime/mppa_k1c/i32_divmod.s | 120 - runtime/mppa_k1c/i64_sdiv.c | 23 - runtime/mppa_k1c/i64_smod.c | 5 - runtime/mppa_k1c/i64_udiv.c | 6 - runtime/mppa_k1c/i64_udivmod.c | 30 - runtime/mppa_k1c/i64_udivmod_stsud.s | 218 -- runtime/mppa_k1c/i64_umod.c | 6 - runtime/mppa_k1c/vararg.s | 54 - test/Makefile | 2 +- test/c/Makefile | 2 +- test/c/aes.c | 2 +- test/c/almabench.c | 2 +- test/c/binarytrees.c | 2 +- test/c/chomp.c | 2 +- test/c/fannkuch.c | 2 +- test/c/fft.c | 2 +- test/c/fftsp.c | 2 +- test/c/fftw.c | 2 +- test/c/fib.c | 2 +- test/c/integr.c | 2 +- test/c/lists.c | 2 +- test/c/mandelbrot.c | 8 +- test/c/nbody.c | 2 +- test/c/nsieve.c | 4 +- test/c/nsievebits.c | 4 +- test/c/perlin.c | 2 +- test/c/qsort.c | 2 +- test/c/sha1.c | 2 +- test/c/sha3.c | 2 +- test/c/siphash24.c | 2 +- test/c/spectral.c | 2 +- test/c/vmach.c | 4 +- test/endian.h | 2 +- test/monniaux/.gitignore | 4 +- test/monniaux/BearSSL/conf/KalrayCompCert.mk | 2 +- test/monniaux/Makefile | 8 +- test/monniaux/PostpassSchedulingOracle.patch | 6 +- test/monniaux/README.md | 4 +- test/monniaux/acswap/test_swapd.c | 2 +- test/monniaux/acswap/test_swapw.c | 2 +- test/monniaux/bitsliced-aes/notes.org | 16 +- test/monniaux/bitsliced-aes/one_file/compare.sh | 14 +- .../bitsliced-aes/one_file/reduce/compare.sh | 20 +- test/monniaux/bitsliced-tea/bstea_wordsize.h | 2 +- test/monniaux/bitsliced-tea/reduce/compare.sh | 18 +- test/monniaux/crypto-algorithms/Makefile | 34 +- test/monniaux/csmith/Makefile | 6 +- test/monniaux/cycles.h | 10 +- .../heapsort/heapsort.ccomp.k1c.s.modified5 | 2 +- .../heapsort/heapsort.ccomp.k1c.s.modified7 | 2 +- test/monniaux/heapsort/heapsort.ccomp.k1c.s.orig | 2 +- test/monniaux/jpeg-6b/Makefile | 32 +- test/monniaux/k1_builtins/atomics.c | 4 +- test/monniaux/k1_builtins/execute_code.c | 2 +- test/monniaux/k1_builtins/sbmm8.c | 4 +- test/monniaux/k1_builtins/test_k1_builtins.c | 50 +- test/monniaux/math/exceptions.c | 6 +- test/monniaux/math/rounding.c | 10 +- test/monniaux/micro-bunzip/Makefile | 24 +- test/monniaux/minisat/Makefile | 18 +- test/monniaux/mod_int_mat/Makefile | 40 +- test/monniaux/multithreaded_volatile/Makefile | 12 +- test/monniaux/ncompress/compress42.c | 2 +- test/monniaux/ocaml/byterun/toto | 682 +++--- test/monniaux/picosat-965/Makefile | 4 +- test/monniaux/quest/Makefile | 8 +- .../quicksort/quicksort.ccomp.k1c.s_modified5 | 2 +- test/monniaux/quicksort/quicksort.ccomp.k1c.s_orig | 2 +- test/monniaux/rules.mk | 34 +- test/monniaux/sandbox/Makefile | 32 +- test/monniaux/send_through/Makefile | 8 +- test/monniaux/varargs/Makefile | 8 +- test/monniaux/vocabulary.sh | 4 +- test/monniaux/yarpgen/Makefile.old | 30 +- test/monniaux/zlib-1.2.11/Makefile | 26 +- test/mppa/.gitignore | 16 +- test/mppa/builtins/stsud.c | 2 +- test/mppa/coverage.sh | 2 +- test/mppa/general/clzd.c | 2 +- test/mppa/general/clzw.c | 2 +- test/mppa/general/ctzd.c | 2 +- test/mppa/general/ctzw.c | 2 +- test/mppa/general/satd.c | 2 +- test/mppa/general/sbmm8.c | 2 +- test/mppa/general/sbmmt8.c | 2 +- test/mppa/instr/Makefile | 20 +- test/mppa/instr/builtin32.c | 4 +- test/mppa/instr/builtin64.c | 8 +- test/mppa/interop/Makefile | 32 +- test/mppa/lib/Makefile | 16 +- test/mppa/mmult/.gitignore | 4 +- test/mppa/mmult/Makefile | 30 +- test/mppa/mmult/README.md | 4 +- test/mppa/prng/.gitignore | 4 +- test/mppa/prng/Makefile | 32 +- test/mppa/prng/README.md | 4 +- test/mppa/sort/.gitignore | 10 +- test/mppa/sort/Makefile | 46 +- test/mppa/sort/README.md | 4 +- test/regression/Makefile | 4 +- test/regression/extasm.c | 2 +- test/regression/varargs2.c | 4 +- 291 files changed, 36247 insertions(+), 36247 deletions(-) delete mode 100755 config_k1c.sh create mode 100755 config_kvx.sh create mode 100644 doc/index-kvx.html delete mode 100644 doc/index-mppa_k1c.html create mode 100644 kvx/Archi.v create mode 100644 kvx/Asm.v create mode 100644 kvx/AsmToJSON.ml create mode 100644 kvx/Asmaux.v create mode 100644 kvx/Asmblock.v create mode 100644 kvx/Asmblockdeps.v create mode 100644 kvx/Asmblockgen.v create mode 100644 kvx/Asmblockgenproof.v create mode 100644 kvx/Asmblockgenproof1.v create mode 100644 kvx/Asmblockprops.v create mode 100644 kvx/Asmexpand.ml create mode 100644 kvx/Asmgen.v create mode 100644 kvx/Asmgenproof.v create mode 100644 kvx/Asmvliw.v create mode 100644 kvx/Builtins1.v create mode 100644 kvx/CBuiltins.ml create mode 100644 kvx/CSE2deps.v create mode 100644 kvx/CSE2depsproof.v create mode 100644 kvx/Chunks.v create mode 100644 kvx/CombineOp.v create mode 100644 kvx/CombineOpproof.v create mode 100644 kvx/ConstpropOp.vp create mode 100644 kvx/ConstpropOpproof.v create mode 100644 kvx/Conventions1.v create mode 100644 kvx/DecBoolOps.v create mode 100644 kvx/DuplicateOpcodeHeuristic.ml create mode 100644 kvx/ExtFloats.v create mode 100644 kvx/ExtValues.v create mode 100644 kvx/InstructionScheduler.ml create mode 100644 kvx/InstructionScheduler.mli create mode 100644 kvx/Machregs.v create mode 100644 kvx/Machregsaux.ml create mode 100644 kvx/Machregsaux.mli create mode 100644 kvx/NeedOp.v create mode 100644 kvx/Op.v create mode 100644 kvx/Peephole.v create mode 100644 kvx/PostpassScheduling.v create mode 100644 kvx/PostpassSchedulingOracle.ml create mode 100644 kvx/PostpassSchedulingproof.v create mode 100644 kvx/PrintOp.ml create mode 100644 kvx/SelectLong.vp create mode 100644 kvx/SelectLongproof.v create mode 100644 kvx/SelectOp.vp create mode 100644 kvx/SelectOpproof.v create mode 100644 kvx/Stacklayout.v create mode 100644 kvx/TargetPrinter.ml create mode 100644 kvx/ValueAOp.v create mode 100644 kvx/abstractbb/AbstractBasicBlocksDef.v create mode 100644 kvx/abstractbb/ImpSimuTest.v create mode 100644 kvx/abstractbb/Impure/ImpConfig.v create mode 100644 kvx/abstractbb/Impure/ImpCore.v create mode 100644 kvx/abstractbb/Impure/ImpExtern.v create mode 100644 kvx/abstractbb/Impure/ImpHCons.v create mode 100644 kvx/abstractbb/Impure/ImpIO.v create mode 100644 kvx/abstractbb/Impure/ImpLoops.v create mode 100644 kvx/abstractbb/Impure/ImpMonads.v create mode 100644 kvx/abstractbb/Impure/ImpPrelude.v create mode 100644 kvx/abstractbb/Impure/LICENSE create mode 100644 kvx/abstractbb/Impure/README.md create mode 100644 kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml create mode 100644 kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli create mode 100644 kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml create mode 100644 kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli create mode 100644 kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml create mode 100644 kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli create mode 100644 kvx/abstractbb/Parallelizability.v create mode 100644 kvx/abstractbb/README.md create mode 100644 kvx/abstractbb/SeqSimuTheory.v create mode 100755 kvx/bitmasks.py create mode 100644 kvx/extractionMachdep.v create mode 100644 kvx/lib/Asmblockgenproof0.v create mode 100644 kvx/lib/ForwardSimulationBlock.v create mode 100644 kvx/lib/Machblock.v create mode 100644 kvx/lib/Machblockgen.v create mode 100644 kvx/lib/Machblockgenproof.v create mode 100644 kvx/unittest/Makefile create mode 100644 kvx/unittest/postpass_test.ml delete mode 100644 mppa_k1c/Archi.v delete mode 100644 mppa_k1c/Asm.v delete mode 100644 mppa_k1c/AsmToJSON.ml delete mode 100644 mppa_k1c/Asmaux.v delete mode 100644 mppa_k1c/Asmblock.v delete mode 100644 mppa_k1c/Asmblockdeps.v delete mode 100644 mppa_k1c/Asmblockgen.v delete mode 100644 mppa_k1c/Asmblockgenproof.v delete mode 100644 mppa_k1c/Asmblockgenproof1.v delete mode 100644 mppa_k1c/Asmblockprops.v delete mode 100644 mppa_k1c/Asmexpand.ml delete mode 100644 mppa_k1c/Asmgen.v delete mode 100644 mppa_k1c/Asmgenproof.v delete mode 100644 mppa_k1c/Asmvliw.v delete mode 100644 mppa_k1c/Builtins1.v delete mode 100644 mppa_k1c/CBuiltins.ml delete mode 100644 mppa_k1c/CSE2deps.v delete mode 100644 mppa_k1c/CSE2depsproof.v delete mode 100644 mppa_k1c/Chunks.v delete mode 100644 mppa_k1c/CombineOp.v delete mode 100644 mppa_k1c/CombineOpproof.v delete mode 100644 mppa_k1c/ConstpropOp.vp delete mode 100644 mppa_k1c/ConstpropOpproof.v delete mode 100644 mppa_k1c/Conventions1.v delete mode 100644 mppa_k1c/DecBoolOps.v delete mode 100644 mppa_k1c/DuplicateOpcodeHeuristic.ml delete mode 100644 mppa_k1c/ExtFloats.v delete mode 100644 mppa_k1c/ExtValues.v delete mode 100644 mppa_k1c/InstructionScheduler.ml delete mode 100644 mppa_k1c/InstructionScheduler.mli delete mode 100644 mppa_k1c/Machregs.v delete mode 100644 mppa_k1c/Machregsaux.ml delete mode 100644 mppa_k1c/Machregsaux.mli delete mode 100644 mppa_k1c/NeedOp.v delete mode 100644 mppa_k1c/Op.v delete mode 100644 mppa_k1c/Peephole.v delete mode 100644 mppa_k1c/PostpassScheduling.v delete mode 100644 mppa_k1c/PostpassSchedulingOracle.ml delete mode 100644 mppa_k1c/PostpassSchedulingproof.v delete mode 100644 mppa_k1c/PrintOp.ml delete mode 100644 mppa_k1c/SelectLong.vp delete mode 100644 mppa_k1c/SelectLongproof.v delete mode 100644 mppa_k1c/SelectOp.vp delete mode 100644 mppa_k1c/SelectOpproof.v delete mode 100644 mppa_k1c/Stacklayout.v delete mode 100644 mppa_k1c/TargetPrinter.ml delete mode 100644 mppa_k1c/ValueAOp.v delete mode 100644 mppa_k1c/abstractbb/AbstractBasicBlocksDef.v delete mode 100644 mppa_k1c/abstractbb/ImpSimuTest.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpConfig.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpCore.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpExtern.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpHCons.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpIO.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpLoops.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpMonads.v delete mode 100644 mppa_k1c/abstractbb/Impure/ImpPrelude.v delete mode 100644 mppa_k1c/abstractbb/Impure/LICENSE delete mode 100644 mppa_k1c/abstractbb/Impure/README.md delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml delete mode 100644 mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli delete mode 100644 mppa_k1c/abstractbb/Parallelizability.v delete mode 100644 mppa_k1c/abstractbb/README.md delete mode 100644 mppa_k1c/abstractbb/SeqSimuTheory.v delete mode 100755 mppa_k1c/bitmasks.py delete mode 100644 mppa_k1c/extractionMachdep.v delete mode 100644 mppa_k1c/lib/Asmblockgenproof0.v delete mode 100644 mppa_k1c/lib/ForwardSimulationBlock.v delete mode 100644 mppa_k1c/lib/Machblock.v delete mode 100644 mppa_k1c/lib/Machblockgen.v delete mode 100644 mppa_k1c/lib/Machblockgenproof.v delete mode 100644 mppa_k1c/unittest/Makefile delete mode 100644 mppa_k1c/unittest/postpass_test.ml delete mode 120000 runtime/c/ccomp_k1c_fixes.h create mode 120000 runtime/c/ccomp_kvx_fixes.h delete mode 100644 runtime/include/ccomp_k1c_fixes.h create mode 100644 runtime/include/ccomp_kvx_fixes.h create mode 100644 runtime/kvx/Makefile create mode 120000 runtime/kvx/ccomp_k1c_fixes.h create mode 100644 runtime/kvx/i32_divmod.s create mode 100644 runtime/kvx/i64_sdiv.c create mode 100644 runtime/kvx/i64_smod.c create mode 100644 runtime/kvx/i64_udiv.c create mode 100644 runtime/kvx/i64_udivmod.c create mode 100644 runtime/kvx/i64_udivmod_stsud.s create mode 100644 runtime/kvx/i64_umod.c create mode 100644 runtime/kvx/vararg.s delete mode 100644 runtime/mppa_k1c/Makefile delete mode 120000 runtime/mppa_k1c/ccomp_k1c_fixes.h delete mode 100644 runtime/mppa_k1c/i32_divmod.s delete mode 100644 runtime/mppa_k1c/i64_sdiv.c delete mode 100644 runtime/mppa_k1c/i64_smod.c delete mode 100644 runtime/mppa_k1c/i64_udiv.c delete mode 100644 runtime/mppa_k1c/i64_udivmod.c delete mode 100644 runtime/mppa_k1c/i64_udivmod_stsud.s delete mode 100644 runtime/mppa_k1c/i64_umod.c delete mode 100644 runtime/mppa_k1c/vararg.s diff --git a/.gitignore b/.gitignore index e886bc10..b19ece42 100644 --- a/.gitignore +++ b/.gitignore @@ -47,9 +47,9 @@ /riscV/ConstpropOp.v /riscV/SelectOp.v /riscV/SelectLong.v -/mppa_k1c/ConstpropOp.v -/mppa_k1c/SelectOp.v -/mppa_k1c/SelectLong.v +/kvx/ConstpropOp.v +/kvx/SelectOp.v +/kvx/SelectLong.v /aarch64/ConstpropOp.v /aarch64/SelectOp.v /aarch64/SelectLong.v @@ -79,11 +79,11 @@ /doc/html/ # MacOS metadata .DS_Store -runtime/mppa_k1c/i64_sdiv.s -runtime/mppa_k1c/i64_smod.s -runtime/mppa_k1c/i64_udiv.s -runtime/mppa_k1c/i64_udivmod.s -runtime/mppa_k1c/i64_umod.s +runtime/kvx/i64_sdiv.s +runtime/kvx/i64_smod.s +runtime/kvx/i64_udiv.s +runtime/kvx/i64_udivmod.s +runtime/kvx/i64_umod.s # Test generated data /test/clightgen/*.v # Coq caches diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1f854fc3..52317ecb 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -14,7 +14,7 @@ check-admitted: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -35,7 +35,7 @@ build_x86_64: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -58,7 +58,7 @@ build_ia32: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -81,7 +81,7 @@ build_aarch64: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -104,7 +104,7 @@ build_arm: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -128,7 +128,7 @@ build_armhf: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -149,7 +149,7 @@ build_ppc: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -170,7 +170,7 @@ build_ppc64: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -193,7 +193,7 @@ build_rv64: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always @@ -214,13 +214,13 @@ build_rv32: rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always - when: manual -build_k1c: +build_kvx: stage: build image: "coqorg/coq" before_script: @@ -228,12 +228,12 @@ build_k1c: - eval `opam config env` - opam install -y menhir script: - - ./config_k1c.sh -no-runtime-lib + - ./config_kvx.sh -no-runtime-lib - make -j "$NJOBS" rules: - if: '$CI_COMMIT_BRANCH == "mppa-work"' when: always - - if: '$CI_COMMIT_BRANCH == "mppa-k1c"' + - if: '$CI_COMMIT_BRANCH == "mppa-kvx"' when: always - if: '$CI_COMMIT_BRANCH == "master"' when: always diff --git a/INSTALL.md b/INSTALL.md index 256bfa4e..4aaa431e 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -36,7 +36,7 @@ opam install coq menhir ## Compilation Pre-compilation configure replace the placeholder with your desired platform -(for Kalray Coolidge it is `k1c-cos`) +(for Kalray Coolidge it is `kvx-cos`) ``` ./configure ``` @@ -57,7 +57,7 @@ ccomp -O3 test.c -o test.bin ``` ## Changing platform -If you decide to change the platform, for instance from k1c-cos to k1c-mbr, you +If you decide to change the platform, for instance from kvx-cos to kvx-mbr, you should change the `compcert.ini` file with the respective tools and then run ``` make install diff --git a/Makefile.extr b/Makefile.extr index f2d06def..1f5e6aeb 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -43,7 +43,7 @@ cparser/pre_parser_messages.ml: DIRS=extraction \ lib common $(ARCH) backend cfrontend cparser driver \ - exportclight debug mppa_k1c/unittest mppa_k1c/abstractbb/Impure/ocaml + exportclight debug kvx/unittest kvx/abstractbb/Impure/ocaml INCLUDES=$(patsubst %,-I %, $(DIRS)) diff --git a/PROFILING.md b/PROFILING.md index 3f4cbc46..8eb8c585 100644 --- a/PROFILING.md +++ b/PROFILING.md @@ -22,13 +22,13 @@ Depending on the platform, this logging system is or is not thread-safe and is o | AArch64 | Yes | Yes | No | | ARM | Yes | No | No | | IA32 | Yes | No | No | -| K1c | Yes | Yes | No | +| KVX | Yes | Yes | No | | PowerPC | No | | | | PowerPC 64 | No | | | | Risc-V 32 | No | | | | Risc-V 64 | No | | | | x86-64 | Yes | Yes | Yes | -For recompiling the program using profiling information, use `-fprofile-use= compcert_profiling.dat -ftracelinearize` (substitute the appropriate filename for `compcert_profiling.dat` if needed). Experiments show performance improvement on K1c, not on other platforms. +For recompiling the program using profiling information, use `-fprofile-use= compcert_profiling.dat -ftracelinearize` (substitute the appropriate filename for `compcert_profiling.dat` if needed). Experiments show performance improvement on KVX, not on other platforms. The same options (except for `-fprofile-use=` and `-fprofile-arcs`) should be used to compile the logging and optimized versions of the program: only functions that are exactly the same in the intermediate representation will be optimized according to profiling information. diff --git a/README_Kalray.md b/README_Kalray.md index 7516daa6..c6509597 100644 --- a/README_Kalray.md +++ b/README_Kalray.md @@ -4,8 +4,8 @@ The verified C compiler ported to Kalray. ## Features This delivery contains (in addition to features from CompCert master branch): -- A fully functional port of CompCert to Coolidge k1c VLIW core -- Postpass scheduling optimization, only for k1c. Activated by default, it can be deactivated with the compiler flag `-fno-postpass` +- A fully functional port of CompCert to Coolidge kvx VLIW core +- Postpass scheduling optimization, only for kvx. Activated by default, it can be deactivated with the compiler flag `-fno-postpass` - Some experimental features that are work in progress: - Slightly better subexpression eliminations, called CSE2 and CSE3. Both go through loops and feature a small alias analysis. - `-fduplicate 0` to activate static branch prediction information. The branch prediction is basic, it annotates each `Icond` node by an `option bool`. A `Some true` annotation indicates we predict the branch will be taken. `Some false` indicates the fallthrough case is predicted. `None` indicates we could not predict anything, and are not sure about which control will be preferred. diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml index 5a8bde8c..fcf8e238 100644 --- a/backend/Selectionaux.ml +++ b/backend/Selectionaux.ml @@ -79,7 +79,7 @@ let fast_cmove ty = | "riscV", _ -> false | "x86", _ -> (match ty with Tint -> true | Tlong -> Archi.ptr64 | _ -> false) - | "mppa_k1c", _ -> true + | "kvx", _ -> true | a, m -> failwith (Printf.sprintf "fast_cmove: unknown arch %s %s" a m) (* The if-conversion heuristic depend on the diff --git a/config_k1c.sh b/config_k1c.sh deleted file mode 100755 index 20408397..00000000 --- a/config_k1c.sh +++ /dev/null @@ -1 +0,0 @@ -exec ./config_simple.sh k1c-cos "$@" diff --git a/config_kvx.sh b/config_kvx.sh new file mode 100755 index 00000000..9040c23b --- /dev/null +++ b/config_kvx.sh @@ -0,0 +1 @@ +exec ./config_simple.sh kvx-cos "$@" diff --git a/configure b/configure index 366ab847..49b84856 100755 --- a/configure +++ b/configure @@ -55,8 +55,8 @@ Supported targets: x86_64-macosx (x86 64 bits, MacOS X) rv32-linux (RISC-V 32 bits, Linux) rv64-linux (RISC-V 64 bits, Linux) - k1c-mbr (Kalray K1c, bare runtime) - k1c-cos (Kalray K1c, ClusterOS) + kvx-mbr (Kalray KVX, bare runtime) + kvx-cos (Kalray KVX, ClusterOS) aarch64-linux (AArch64, i.e. ARMv8 in 64-bit mode, Linux) manual (edit configuration file by hand) @@ -179,8 +179,8 @@ case "$target" in arch="riscV"; model="32"; endianness="little"; bitsize=32;; rv64-*) arch="riscV"; model="64"; endianness="little"; bitsize=64;; - k1c-*) - arch="mppa_k1c"; model="64"; endianness="little"; bitsize=64;; + kvx-*) + arch="kvx"; model="64"; endianness="little"; bitsize=64;; aarch64-*|arm64-*) arch="aarch64"; model="default"; endianness="little"; bitsize=64;; manual) @@ -437,9 +437,9 @@ if test "$arch" = "riscV"; then fi # -# K1c Target Configuration +# KVX Target Configuration # -if test "$arch" = "mppa_k1c"; then +if test "$arch" = "kvx"; then #model_options="-march=rv64imafd -mabi=lp64d" # FIXME - maybe later add it for NodeOS & cie #model_options=-m64 @@ -452,12 +452,12 @@ if test "$arch" = "mppa_k1c"; then elif test "$target" = "elf"; then os="elf"; else - echo "Unknown K1c backend" + echo "Unknown KVX backend" exit 1 fi osupper=`echo $os|tr a-z A-Z` - k1base="k1-$os" - casm="k1-elf-as" + k1base="kvx-$os" + casm="kvx-elf-as" casm_options="$model_options" cc="$k1base-gcc $model_options" clinker="$k1base-gcc" @@ -465,7 +465,7 @@ if test "$arch" = "mppa_k1c"; then libdir="$HOME/.usr/lib" clinker_options="$model_options -L$libdir -Wl,-rpath=$libdir" cprepro="$k1base-gcc" - cprepro_options="$model_options -D __K1C_${osupper}__ -std=c99 -E -include ccomp_k1c_fixes.h" + cprepro_options="$model_options -D __KVX_${osupper}__ -std=c99 -E -include ccomp_kvx_fixes.h" libmath="-lm" system="linux" fi @@ -838,12 +838,12 @@ RESPONSEFILE="none" EOF fi -if [ "$arch" = "mppa_k1c" ]; then +if [ "$arch" = "kvx" ]; then cat >> Makefile.config < t diff --git a/doc/index-kvx.html b/doc/index-kvx.html new file mode 100644 index 00000000..ae01d2d6 --- /dev/null +++ b/doc/index-kvx.html @@ -0,0 +1,362 @@ + + + +The CompCert verified compiler + + + + + + + +

    The CompCert verified compiler

    +

    Commented Coq development

    +

    Version 3.7, 2020-03-31

    +

    PATCHED for the Kalray MPPA-KVX VLIW CORE

    + +

    Introduction

    + +

    This web page is a patched version of the table of contents of the official CompCert documentation, + as given on the CompCert Web site. + The unmodified parts of this table appear in gray. + + +

    Table of contents

    + +

    General-purpose libraries, data structures and algorithms

    + +
      +
    • Coqlib: addendum to the Coq standard library. +
    • Maps: finite maps. +
    • Integers: machine integers. +
    • Floats: machine floating-point numbers. +
    • Iteration: various forms of "while" loops. +
    • Ordered: construction of +ordered types. +
    • Lattice: construction of +semi-lattices. +
    • Kildall: resolution of dataflow +inequations by fixpoint iteration. +
    • UnionFind: a persistent union-find data structure. +
    • Postorder: postorder numbering of a directed graph. +
    + +

    The abstractbb library, introduced for MPPA-KVX

    +
      +
    • AbstractBasicBlocksDef: an IR for verifying some semantic properties on basic-blocks. +
    • Parallelizability: verifying that sequential and parallel semantics are equivalent for a given abstract basic-block. +
    • ImpSimuTest: verifying that a given abstract basic-block is simulated by another one for sequential semantics. This module refines SeqSimuTheory with hash-consing. +
    + + +

    Definitions and theorems used in many parts of the development

    + +
      +
    • Errors: the Error monad. +
    • AST: identifiers, whole programs and other +common elements of abstract syntaxes. +
    • Linking: generic framework to define syntactic linking over the CompCert languages. +
    • Values: run-time values. +
    • Events: observable events and traces. +
    • Memory: memory model.
      +See also: Memdata (in-memory representation of data). +
    • Globalenvs: global execution environments. +
    • Smallstep: tools for small-step semantics. +
    • Behaviors: from small-step semantics to observable behaviors of programs. +
    • Determinism: determinism properties of small-step semantics. +
    • Op: operators, addressing modes and their +semantics. +
    • Unityping: a solver for atomic unification constraints. +
    + +

    Source, intermediate and target languages: syntax and semantics

    + +
      +
    • The CompCert C source language: +syntax and +semantics and +determinized semantics and +type system.
      +See also: type expressions and +operators (syntax and semantics).
      +See also: reference interpreter. +
    • Clight: a simpler version of CompCert C where expressions contain no side-effects. +
    • Csharpminor: low-level + structured language. +
    • Cminor: low-level structured +language, with explicit stack allocation of certain local variables. +
    • CminorSel: like Cminor, +with machine-specific operators and addressing modes. +
    • RTL: register transfer language (3-address +code, control-flow graph, infinitely many pseudo-registers).
      +See also: Registers (representation of +pseudo-registers). +
    • LTL: location transfer language (3-address +code, control-flow graph of basic blocks, finitely many physical registers, infinitely +many stack slots).
      +See also: Locations (representation of +locations) and Machregs (description of processor registers). +
    • Linear: like LTL, but the CFG is +replaced by a linear list of instructions with explicit branches and labels. +
    • Mach: like Linear, with a more concrete +view of the activation record. +
    +
    +

    Languages introduced for MPPA-KVX

    +
      +
    • Machblock: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step). +This IR is generic over the processor, even if currently, only used for MPPA_KVX. +
    • Asmvliw: abstract syntax and semantics for Mppa_KVX VLIW assembly: atomic instructions are grouped by "bundles". These bundles are executed sequentially, but execution is parallel within bundles. +
    • Asmblock: a variant of Asmvliw, with a sequential semantics within bundles, which make them corresponds here to usual basic-blocks. + This IR is an intermediate step between Machblock and Asmvliw. +
    • Asm: a variant of Asmvliw with a flat syntax for bundles, instead of a structured one (bundle termination is encoded as a pseudo-instruction). This IR is mainly a wrapper of Asmvliw for a smooth integration in CompCert (and an easier pretty-printing of the abstract syntax). +
    + +

    Compiler passes

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    PassSource & targetCompiler codeCorrectness proof
    Pulling side-effects out of expressions;
    + fixing an evaluation order
    CompCert C to ClightSimplExprSimplExprspec
    + SimplExprproof
    Pulling non-adressable scalar local variables out of memoryClight to ClightSimplLocalsSimplLocalsproof
    Simplification of control structures;
    + explication of type-dependent computations
    Clight to CsharpminorCshmgenCshmgenproof
    Stack allocation of local variables
    + whose address is taken;
    + simplification of switch statements
    Csharpminor to CminorCminorgenCminorgenproof
    Recognition of operators
    and addressing modes
    Cminor to CminorSelSelection
    + SelectOp
    + SelectLong
    + SelectDiv
    + SplitLong
    Selectionproof
    + SelectOpproof
    + SelectLongproof
    + SelectDivproof
    + SplitLongproof
    Construction of the CFG,
    3-address code generation
    CminorSel to RTLRTLgenRTLgenspec
    + RTLgenproof
    Recognition of tail callsRTL to RTLTailcallTailcallproof
    Function inliningRTL to RTLInliningInliningspec
    + Inliningproof
    Postorder renumbering of the CFGRTL to RTLRenumberRenumberproof
    Constant propagationRTL to RTLConstprop
    + ConstpropOp
    Constpropproof
    + ConstproppOproof
    Common subexpression eliminationRTL to RTLCSE
    + CombineOp
    CSEproof
    + CombineOpproof
    Redundancy eliminationRTL to RTLDeadcodeDeadcodeproof
    Removal of unused static globalsRTL to RTLUnusedglobUnusedglobproof
    Register allocation (validation a posteriori)RTL to LTLAllocationAllocproof
    Branch tunnelingLTL to LTLTunnelingTunnelingproof
    Linearization of the CFGLTL to LinearLinearizeLinearizeproof
    Removal of unreferenced labelsLinear to LinearCleanupLabelsCleanupLabelsproof
    Synthesis of debugging informationLinear to LinearDebugvarDebugvarproof
    Laying out the activation recordsLinear to MachStacking
    + Bounds
    + Stacklayout
    Stackingproof
    + Separation
    + +

    Compilation passes introduced for MPPA-KVX

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Reconstruction of basic-blocks at Mach levelMach to MachblockMachblockgenForwardSimulationBlock
    + Machblockgenproof
    Emission of purely sequential assembly codeMachblock to AsmblockAsmblockgenAsmblockgenproof0
    + Asmblockgenproof1
    + Asmblockgenproof
    Bundling (and basic-block scheduling)Asmblock to AsmvliwPostpassScheduling using
    + Asmblockdeps and the abstractbb library
    PostpassSchedulingproof
    Flattening bundles (only a bureaucratic operation)Asmvliw to AsmAsmgenAsmgenproof
    + + +

    All together

    + +
      +
    • Compiler: composing the passes together; +whole-compiler semantic preservation theorems. +
    • Complements: interesting consequences of the semantic preservation theorems. +
    + +

    Static analyses

    + +The following static analyses are performed over the RTL intermediate +representation to support optimizations such as constant propagation, +CSE, and dead code elimination. +
      +
    • Liveness: liveness analysis. +
    • ValueAnalysis: value and alias analysis
      +See also: ValueDomain: the abstract domain for value analysis.
      +See also: ValueAOp: processor-dependent parts of value analysis. +
    • Deadcode: neededness analysis
      +See also: NeedDomain: the abstract domain for neededness analysis.
      +See also: NeedOp: processor-dependent parts of neededness analysis. +
    + +

    Type systems

    + +The type system of CompCert C is fully formalized. For some intermediate languages of the back-end, simpler type systems are used to statically capture well-formedness conditions. +
      +
    • Ctyping: typing for CompCert C + type-checking functions. +
    • RTLtyping: typing for RTL + type +reconstruction. +
    • Lineartyping: typing for Linear. +
    +
    + + + diff --git a/doc/index-mppa_k1c.html b/doc/index-mppa_k1c.html deleted file mode 100644 index 86fd4166..00000000 --- a/doc/index-mppa_k1c.html +++ /dev/null @@ -1,362 +0,0 @@ - - - -The CompCert verified compiler - - - - - - - -

    The CompCert verified compiler

    -

    Commented Coq development

    -

    Version 3.7, 2020-03-31

    -

    PATCHED for the Kalray MPPA-K1C VLIW CORE

    - -

    Introduction

    - -

    This web page is a patched version of the table of contents of the official CompCert documentation, - as given on the CompCert Web site. - The unmodified parts of this table appear in gray. - - -

    Table of contents

    - -

    General-purpose libraries, data structures and algorithms

    - -
      -
    • Coqlib: addendum to the Coq standard library. -
    • Maps: finite maps. -
    • Integers: machine integers. -
    • Floats: machine floating-point numbers. -
    • Iteration: various forms of "while" loops. -
    • Ordered: construction of -ordered types. -
    • Lattice: construction of -semi-lattices. -
    • Kildall: resolution of dataflow -inequations by fixpoint iteration. -
    • UnionFind: a persistent union-find data structure. -
    • Postorder: postorder numbering of a directed graph. -
    - -

    The abstractbb library, introduced for MPPA-K1C

    -
      -
    • AbstractBasicBlocksDef: an IR for verifying some semantic properties on basic-blocks. -
    • Parallelizability: verifying that sequential and parallel semantics are equivalent for a given abstract basic-block. -
    • ImpSimuTest: verifying that a given abstract basic-block is simulated by another one for sequential semantics. This module refines SeqSimuTheory with hash-consing. -
    - - -

    Definitions and theorems used in many parts of the development

    - -
      -
    • Errors: the Error monad. -
    • AST: identifiers, whole programs and other -common elements of abstract syntaxes. -
    • Linking: generic framework to define syntactic linking over the CompCert languages. -
    • Values: run-time values. -
    • Events: observable events and traces. -
    • Memory: memory model.
      -See also: Memdata (in-memory representation of data). -
    • Globalenvs: global execution environments. -
    • Smallstep: tools for small-step semantics. -
    • Behaviors: from small-step semantics to observable behaviors of programs. -
    • Determinism: determinism properties of small-step semantics. -
    • Op: operators, addressing modes and their -semantics. -
    • Unityping: a solver for atomic unification constraints. -
    - -

    Source, intermediate and target languages: syntax and semantics

    - -
      -
    • The CompCert C source language: -syntax and -semantics and -determinized semantics and -type system.
      -See also: type expressions and -operators (syntax and semantics).
      -See also: reference interpreter. -
    • Clight: a simpler version of CompCert C where expressions contain no side-effects. -
    • Csharpminor: low-level - structured language. -
    • Cminor: low-level structured -language, with explicit stack allocation of certain local variables. -
    • CminorSel: like Cminor, -with machine-specific operators and addressing modes. -
    • RTL: register transfer language (3-address -code, control-flow graph, infinitely many pseudo-registers).
      -See also: Registers (representation of -pseudo-registers). -
    • LTL: location transfer language (3-address -code, control-flow graph of basic blocks, finitely many physical registers, infinitely -many stack slots).
      -See also: Locations (representation of -locations) and Machregs (description of processor registers). -
    • Linear: like LTL, but the CFG is -replaced by a linear list of instructions with explicit branches and labels. -
    • Mach: like Linear, with a more concrete -view of the activation record. -
    -
    -

    Languages introduced for MPPA-K1C

    -
      -
    • Machblock: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step). -This IR is generic over the processor, even if currently, only used for MPPA_K1C. -
    • Asmvliw: abstract syntax and semantics for Mppa_K1c VLIW assembly: atomic instructions are grouped by "bundles". These bundles are executed sequentially, but execution is parallel within bundles. -
    • Asmblock: a variant of Asmvliw, with a sequential semantics within bundles, which make them corresponds here to usual basic-blocks. - This IR is an intermediate step between Machblock and Asmvliw. -
    • Asm: a variant of Asmvliw with a flat syntax for bundles, instead of a structured one (bundle termination is encoded as a pseudo-instruction). This IR is mainly a wrapper of Asmvliw for a smooth integration in CompCert (and an easier pretty-printing of the abstract syntax). -
    - -

    Compiler passes

    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    PassSource & targetCompiler codeCorrectness proof
    Pulling side-effects out of expressions;
    - fixing an evaluation order
    CompCert C to ClightSimplExprSimplExprspec
    - SimplExprproof
    Pulling non-adressable scalar local variables out of memoryClight to ClightSimplLocalsSimplLocalsproof
    Simplification of control structures;
    - explication of type-dependent computations
    Clight to CsharpminorCshmgenCshmgenproof
    Stack allocation of local variables
    - whose address is taken;
    - simplification of switch statements
    Csharpminor to CminorCminorgenCminorgenproof
    Recognition of operators
    and addressing modes
    Cminor to CminorSelSelection
    - SelectOp
    - SelectLong
    - SelectDiv
    - SplitLong
    Selectionproof
    - SelectOpproof
    - SelectLongproof
    - SelectDivproof
    - SplitLongproof
    Construction of the CFG,
    3-address code generation
    CminorSel to RTLRTLgenRTLgenspec
    - RTLgenproof
    Recognition of tail callsRTL to RTLTailcallTailcallproof
    Function inliningRTL to RTLInliningInliningspec
    - Inliningproof
    Postorder renumbering of the CFGRTL to RTLRenumberRenumberproof
    Constant propagationRTL to RTLConstprop
    - ConstpropOp
    Constpropproof
    - ConstproppOproof
    Common subexpression eliminationRTL to RTLCSE
    - CombineOp
    CSEproof
    - CombineOpproof
    Redundancy eliminationRTL to RTLDeadcodeDeadcodeproof
    Removal of unused static globalsRTL to RTLUnusedglobUnusedglobproof
    Register allocation (validation a posteriori)RTL to LTLAllocationAllocproof
    Branch tunnelingLTL to LTLTunnelingTunnelingproof
    Linearization of the CFGLTL to LinearLinearizeLinearizeproof
    Removal of unreferenced labelsLinear to LinearCleanupLabelsCleanupLabelsproof
    Synthesis of debugging informationLinear to LinearDebugvarDebugvarproof
    Laying out the activation recordsLinear to MachStacking
    - Bounds
    - Stacklayout
    Stackingproof
    - Separation
    - -

    Compilation passes introduced for MPPA-K1C

    - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    Reconstruction of basic-blocks at Mach levelMach to MachblockMachblockgenForwardSimulationBlock
    - Machblockgenproof
    Emission of purely sequential assembly codeMachblock to AsmblockAsmblockgenAsmblockgenproof0
    - Asmblockgenproof1
    - Asmblockgenproof
    Bundling (and basic-block scheduling)Asmblock to AsmvliwPostpassScheduling using
    - Asmblockdeps and the abstractbb library
    PostpassSchedulingproof
    Flattening bundles (only a bureaucratic operation)Asmvliw to AsmAsmgenAsmgenproof
    - - -

    All together

    - -
      -
    • Compiler: composing the passes together; -whole-compiler semantic preservation theorems. -
    • Complements: interesting consequences of the semantic preservation theorems. -
    - -

    Static analyses

    - -The following static analyses are performed over the RTL intermediate -representation to support optimizations such as constant propagation, -CSE, and dead code elimination. -
      -
    • Liveness: liveness analysis. -
    • ValueAnalysis: value and alias analysis
      -See also: ValueDomain: the abstract domain for value analysis.
      -See also: ValueAOp: processor-dependent parts of value analysis. -
    • Deadcode: neededness analysis
      -See also: NeedDomain: the abstract domain for neededness analysis.
      -See also: NeedOp: processor-dependent parts of neededness analysis. -
    - -

    Type systems

    - -The type system of CompCert C is fully formalized. For some intermediate languages of the back-end, simpler type systems are used to statically capture well-formedness conditions. -
      -
    • Ctyping: typing for CompCert C + type-checking functions. -
    • RTLtyping: typing for RTL + type -reconstruction. -
    • Lineartyping: typing for Linear. -
    -
    - - - diff --git a/driver/Clflags.ml b/driver/Clflags.ml index b0d3740e..eb21b3f8 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -15,7 +15,7 @@ let prepro_options = ref ([]: string list) let linker_options = ref ([]: string list) let assembler_options = ref ([]: string list) -let option_flongdouble = ref (Configuration.arch = "mppa_k1c") +let option_flongdouble = ref (Configuration.arch = "kvx") let option_fstruct_passing = ref false let option_fbitfields = ref false let option_fvararg_calls = ref true diff --git a/driver/Configuration.ml b/driver/Configuration.ml index 08084720..1d40214a 100644 --- a/driver/Configuration.ml +++ b/driver/Configuration.ml @@ -123,7 +123,7 @@ let get_bool_config key = let arch = match get_config_string "arch" with - | "powerpc"|"arm"|"x86"|"riscV"|"mppa_k1c"|"aarch64" as a -> a + | "powerpc"|"arm"|"x86"|"riscV"|"kvx"|"aarch64" as a -> a | v -> bad_config "arch" [v] let model = get_config_string "model" let abi = get_config_string "abi" diff --git a/driver/Frontend.ml b/driver/Frontend.ml index b9db0d23..5db0040f 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -116,7 +116,7 @@ let init () = | "riscV" -> if Configuration.model = "64" then Machine.rv64 else Machine.rv32 - | "mppa_k1c" -> Machine.mppa_k1c + | "kvx" -> Machine.kvx | "aarch64" -> Machine.aarch64 | _ -> assert false end; diff --git a/kvx/Archi.v b/kvx/Archi.v new file mode 100644 index 00000000..6d59a3d1 --- /dev/null +++ b/kvx/Archi.v @@ -0,0 +1,80 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Architecture-dependent parameters for MPPA KVX. Mostly copied from the Risc-V backend *) + +Require Import ZArith List. +Require Import Binary Bits. + +Definition ptr64 := true. + +Definition big_endian := false. + +Definition align_int64 := 8%Z. +Definition align_float64 := 8%Z. + +Definition splitlong := false. + +Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. +Proof. + unfold splitlong. congruence. +Qed. + +(** FIXME - Check the properties below *) + +(** Section 7.3: "Except when otherwise stated, if the result of a + floating-point operation is NaN, it is the canonical NaN. The + canonical NaN has a positive sign and all significand bits clear + except the MSB, a.k.a. the quiet bit." + We need to extend the [choose_binop_pl] functions to account for + this case. *) + +Definition default_nan_64 := (false, iter_nat 51 _ xO xH). +Definition default_nan_32 := (false, iter_nat 22 _ xO xH). + +(* Always choose the first NaN argument, if any *) + +Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_64 | n :: _ => n end. + +Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := + match l with nil => default_nan_32 | n :: _ => n end. + +Definition fpu_returns_default_qNaN := false. + +Lemma choose_nan_64_idem: forall n, + choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). +Proof. auto. Qed. + +Lemma choose_nan_32_idem: forall n, + choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). +Proof. auto. Qed. + +Definition fma_order {A: Type} (x y z: A) := (x, z, y). + +Definition fma_invalid_mul_is_nan := false. +Definition float_of_single_preserves_sNaN := false. + +Global Opaque ptr64 big_endian splitlong + default_nan_64 choose_nan_64 + default_nan_32 choose_nan_32 + fma_order fma_invalid_mul_is_nan + float_of_single_preserves_sNaN. + +(** Whether to generate position-independent code or not *) + +Parameter pic_code: unit -> bool. + +Definition has_notrap_loads := true. diff --git a/kvx/Asm.v b/kvx/Asm.v new file mode 100644 index 00000000..69d0ecf6 --- /dev/null +++ b/kvx/Asm.v @@ -0,0 +1,751 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Abstract syntax for KVX textual assembly language. + + Each emittable instruction is defined here. ';;' is also defined as an instruction. + The goal of this representation is to stay compatible with the rest of the generic backend of CompCert + We define [unfold : list bblock -> list instruction] + An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] + [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Asmvliw. +Require Import Linking. +Require Import Errors. + +(** Definitions for OCaml code *) +Definition label := positive. +Definition preg := preg. + +Inductive addressing : Type := + | AOff (ofs: offset) + | AReg (ro: ireg) + | ARegXS (ro: ireg) +. + +(** Syntax *) +Inductive instruction : Type := + (** pseudo instructions *) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Plabel (lbl: label) (**r define a code label *) + | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> instruction (**r built-in function (pseudo) *) + | Psemi (**r semi colon separating bundles *) + | Pnop (**r instruction that does nothing *) + + (** Control flow instructions *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (rs: ireg) (**r function call on register *) + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (rs: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) + | Pjumptable (r: ireg) (labels: list label) + + (* For builtins *) + | Ploopdo (count: ireg) (loopend: label) + | Pgetn (n: int) (dst: ireg) + | Psetn (n: int) (src: ireg) + | Pwfxl (n: int) (src: ireg) + | Pwfxm (n: int) (src: ireg) + | Pldu (dst: ireg) (addr: ireg) + | Plbzu (dst: ireg) (addr: ireg) + | Plhzu (dst: ireg) (addr: ireg) + | Plwzu (dst: ireg) (addr: ireg) + | Pawait + | Psleep + | Pstop + | Pbarrier + | Pfence + | Pdinval + | Pdinvall (addr: ireg) + | Pdtouchl (addr: ireg) + | Piinval + | Piinvals (addr: ireg) + | Pitouchl (addr: ireg) + | Pdzerol (addr: ireg) +(*| Pafaddd (addr: ireg) (incr_res: ireg) + | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) + | Palclrd (dst: ireg) (addr: ireg) + | Palclrw (dst: ireg) (addr: ireg) + | Pclzll (rd rs: ireg) + | Pstsud (rd rs1 rs2: ireg) + + (** Loads **) + | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) + | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) + | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) + | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) + | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) + | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) + | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) + | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) + | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) + | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) + | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) + | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) + + (** Stores **) + | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) + | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) + | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) + | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) + | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) + | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) + | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) + | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) + + | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) + + (** Arith RR *) + | Pmv (rd rs: ireg) (**r register move *) + | Pnegw (rd rs: ireg) (**r negate word *) + | Pnegl (rd rs: ireg) (**r negate long *) + | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) + | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) + | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) + + | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) + | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) + + | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) + + | Pfabsd (rd rs: ireg) (**r float absolute double *) + | Pfabsw (rd rs: ireg) (**r float absolute word *) + | Pfnegd (rd rs: ireg) (**r float negate double *) + | Pfnegw (rd rs: ireg) (**r float negate word *) + | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) + | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) + | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) + | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) + | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) + | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) + | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) + | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) + | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) + | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) + | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) + + (** Arith RI32 *) + | Pmake (rd: ireg) (imm: int) (**r load immediate *) + + (** Arith RI64 *) + | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) + + (** Arith RF32 *) + | Pmakefs (rd: ireg) (imm: float32) + + (** Arith RF64 *) + | Pmakef (rd: ireg) (imm: float) + + (** Arith RRR *) + | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) + | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) + | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) + | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) + + | Paddw (rd rs1 rs2: ireg) (**r add word *) + | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Psubw (rd rs1 rs2: ireg) (**r sub word *) + | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) + | Pmulw (rd rs1 rs2: ireg) (**r mul word *) + | Pandw (rd rs1 rs2: ireg) (**r and word *) + | Pnandw (rd rs1 rs2: ireg) (**r nand word *) + | Porw (rd rs1 rs2: ireg) (**r or word *) + | Pnorw (rd rs1 rs2: ireg) (**r nor word *) + | Pxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) + | Pandnw (rd rs1 rs2: ireg) (**r andn word *) + | Pornw (rd rs1 rs2: ireg) (**r orn word *) + | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) + | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) + | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) + | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) + | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) + | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) + | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) + | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) + | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) + + | Paddl (rd rs1 rs2: ireg) (**r add long *) + | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) + | Psubl (rd rs1 rs2: ireg) (**r sub long *) + | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) + | Pandl (rd rs1 rs2: ireg) (**r and long *) + | Pnandl (rd rs1 rs2: ireg) (**r nand long *) + | Porl (rd rs1 rs2: ireg) (**r or long *) + | Pnorl (rd rs1 rs2: ireg) (**r nor long *) + | Pxorl (rd rs1 rs2: ireg) (**r xor long *) + | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) + | Pandnl (rd rs1 rs2: ireg) (**r andn long *) + | Pornl (rd rs1 rs2: ireg) (**r orn long *) + | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) + | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) + | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) + | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) + | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) + | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) + | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) + + | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) + | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) + | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) + | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) + | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) + | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) + | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) + | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) + | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) + | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) + | Pfinvw (rd rs1: ireg) (**r Float invert word *) + + (** Arith RRI32 *) + | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) + + | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) + | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) + | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) + | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) + | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) + | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) + | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) + | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) + | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) + | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) + | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) + | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) + | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) + | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) + | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) + | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) + | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) + | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) + | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) + | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) + | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) + + (** Arith RRI64 *) + | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) + | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) + | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) + | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) + | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) + | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) + | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) + | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) + | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) + | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) + | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) + | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) + | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) + | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) + | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) +. + +(** Correspondance between Asmblock and Asm *) + +Definition control_to_instruction (c: control) := + match c with + | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res + | PCtlFlow Asmvliw.Pret => Pret + | PCtlFlow (Asmvliw.Pcall l) => Pcall l + | PCtlFlow (Asmvliw.Picall r) => Picall r + | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l + | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l + | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l + | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l + | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l + | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label + end. + +Definition basic_to_instruction (b: basic) := + match b with + (** Special basics *) + | Asmvliw.Pget rd rs => Pget rd rs + | Asmvliw.Pset rd rs => Pset rd rs + | Asmvliw.Pnop => Pnop + | Asmvliw.Pallocframe sz pos => Pallocframe sz pos + | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos + + (** PArith basics *) + (* R *) + | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs + + (* RR *) + | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs + | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs + | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs + | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs + | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs + | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs + | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start + | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start + | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start + | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start + | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs + | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs + | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs + | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs + | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs + | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs + | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs + | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs + | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs + | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs + | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs + | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs + | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs + | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs + | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs + | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs + + (* RI32 *) + | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm + + (* RI64 *) + | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm + + (* RF32 *) + | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm + + (* RF64 *) + | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm + + (* RRR *) + | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 + | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 + | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 + | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 + | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 + | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 + | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 + | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 + | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 + | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 + | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 + | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 + | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 + | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 + | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 + + | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 + | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 + | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 + | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 + | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 + | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 + | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 + | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 + | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 + | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 + | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 + | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 + | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 + | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 + | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 + + | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 + | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 + | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 + | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 + | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 + | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 + + (* RRI32 *) + | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm + | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm + | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm + | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm + | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm + | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm + | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm + | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm + | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm + | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm + | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm + | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm + | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm + | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm + | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm + | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm + | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm + | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm + | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm + | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm + | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm + | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm + | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm + + (* RRI64 *) + | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm + | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm + | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm + | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm + | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm + | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm + | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm + | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm + | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm + | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm + | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm + | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm + | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm + | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm + + (** ARRR *) + | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 + | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 + | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 + | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 + | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 + + (** ARR *) + | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start + | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start + + (** ARRI32 *) + | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm + | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm + + (** ARRI64 *) + | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm + | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm + (** Load *) + | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) + | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) + + | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) + | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) + + | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) + | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) + + | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) + | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) + + (** Store *) + | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) + | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) + | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) + + | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) + | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) + | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) + | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) + | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) + + | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) + | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) + + | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) + | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) + end. + +Section RELSEM. + +Definition code := list instruction. + +Fixpoint unfold_label (ll: list label) := + match ll with + | nil => nil + | l :: ll => Plabel l :: unfold_label ll + end. + +Fixpoint unfold_body (lb: list basic) := + match lb with + | nil => nil + | b :: lb => basic_to_instruction b :: unfold_body lb + end. + +Definition unfold_exit (oc: option control) := + match oc with + | None => nil + | Some c => control_to_instruction c :: nil + end. + +Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ + (match (body b), (exit b) with + | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => + unfold_body bo + | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil + end). + +Fixpoint unfold (lb: bblocks) := + match lb with + | nil => nil + | b :: lb => (unfold_bblock b) ++ unfold lb + end. + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; + correct: unfold fn_blocks = fn_code }. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. +Definition genv := Genv.t fundef unit. + +Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). + +Definition fundef_proj (fu: fundef) : Asmvliw.fundef := + match fu with + | Internal f => Internal (function_proj f) + | External ef => External ef + end. + +Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := + match gd with + | Gfun f => Gfun (fundef_proj f) + | Gvar gu => Gvar gu + end. + +Program Definition genv_trans (ge: genv) : Asmvliw.genv := + {| Genv.genv_public := Genv.genv_public ge; + Genv.genv_symb := Genv.genv_symb ge; + Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); + Genv.genv_next := Genv.genv_next ge |}. +Next Obligation. + destruct ge. simpl in *. eauto. +Qed. Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gmap1 in H. + destruct (genv_defs ! b) eqn:GEN. + - eauto. + - discriminate. +Qed. Next Obligation. + destruct ge; simpl in *. + eauto. +Qed. + +Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) + : list (ident * globdef Asmvliw.fundef unit) := + match l with + | nil => nil + | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l + end. + +Definition program_proj (p: program) : Asmvliw.program := + {| prog_defs := prog_defs_proj (prog_defs p); + prog_public := prog_public p; + prog_main := prog_main p + |}. + +End RELSEM. + +Definition semantics (p: program) := Asmvliw.semantics (program_proj p). + +(** Determinacy of the [Asm] semantics. *) + +Lemma semantics_determinate: forall p, determinate (semantics p). +Proof. + intros. apply semantics_determinate. +Qed. + +(** transf_program *) + +Program Definition transf_function (f: Asmvliw.function) : function := + {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; + fn_code := unfold (Asmvliw.fn_blocks f) |}. + +Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. +Proof. + intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. +Qed. + +Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. + +Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. +Proof. + intros f. destruct f as [f|e]; simpl; auto. + rewrite transf_function_proj. auto. +Qed. + +Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. + +Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), + prog_defs p1 = prog_defs p2 -> + prog_public p1 = prog_public p2 -> + prog_main p1 = prog_main p2 -> + p1 = p2. +Proof. + intros. destruct p1. destruct p2. simpl in *. subst. auto. +Qed. + +Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. +Proof. + intros p. destruct p as [defs pub main]. unfold program_proj. simpl. + apply program_equals; simpl; auto. + induction defs. + - simpl; auto. + - simpl. rewrite IHdefs. + destruct a as [id gd]; simpl. + destruct gd as [f|v]; simpl; auto. + rewrite transf_fundef_proj. auto. +Qed. + +Definition match_prog (p: Asmvliw.program) (tp: program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. +Proof. + intros. congruence. +Qed. + +Lemma match_program_transf: + forall p tp, match_prog p tp -> transf_program p = tp. +Proof. + intros p tp H. inversion_clear H. inv H1. + destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. + subst. unfold transf_program. unfold transform_program. simpl. + apply program_equals; simpl; auto. + induction H0; simpl; auto. + rewrite IHlist_forall2. apply cons_extract. + destruct a1 as [ida gda]. destruct b1 as [idb gdb]. + simpl in *. + inv H. inv H2. + - simpl in *. subst. auto. + - simpl in *. subst. inv H. auto. +Qed. + +Section PRESERVATION. + +Variable prog: Asmvliw.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Definition match_states (s1 s2: state) := s1 = s2. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + + +Theorem transf_program_correct: + forward_simulation (Asmvliw.semantics prog) (semantics tprog). +Proof. + pose proof (match_program_transf prog tprog TRANSF) as TR. + subst. unfold semantics. rewrite transf_program_proj. + + eapply forward_simulation_step with (match_states := match_states); simpl; auto. + - intros. exists s1. split; auto. congruence. + - intros. inv H. auto. + - intros. exists s1'. inv H0. split; auto. congruence. +Qed. + +End PRESERVATION. diff --git a/kvx/AsmToJSON.ml b/kvx/AsmToJSON.ml new file mode 100644 index 00000000..8a6a97a7 --- /dev/null +++ b/kvx/AsmToJSON.ml @@ -0,0 +1,23 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) +(* *) +(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) +(* is distributed under the terms of the INRIA Non-Commercial *) +(* License Agreement. *) +(* *) +(* *********************************************************************) + +(* Simple functions to serialize RISC-V Asm to JSON *) + +(* Dummy function *) +let destination: string option ref = ref None + +let sdump_folder = ref "" + +let print_if prog sourcename = + () + +let pp_mnemonics pp = () diff --git a/kvx/Asmaux.v b/kvx/Asmaux.v new file mode 100644 index 00000000..2abd445e --- /dev/null +++ b/kvx/Asmaux.v @@ -0,0 +1,19 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Asm. +Require Import AST. + +(** Constant only needed by Asmexpandaux.ml *) +Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. diff --git a/kvx/Asmblock.v b/kvx/Asmblock.v new file mode 100644 index 00000000..9c8e4cc3 --- /dev/null +++ b/kvx/Asmblock.v @@ -0,0 +1,393 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Sequential block semantics for KVX assembly. The syntax is given in AsmVLIW *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Errors. +Require Export Asmvliw. + +(* Notations necessary to hook Asmvliw definitions *) +Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs. +Notation regset := Asmvliw.regset. +Notation extcall_arg := Asmvliw.extcall_arg. +Notation extcall_arg_pair := Asmvliw.extcall_arg_pair. +Notation extcall_arguments := Asmvliw.extcall_arguments. +Notation set_res := Asmvliw.set_res. +Notation function := Asmvliw.function. +Notation bblocks := Asmvliw.bblocks. +Notation header := Asmvliw.header. +Notation body := Asmvliw.body. +Notation exit := Asmvliw.exit. +Notation correct := Asmvliw.correct. + +(** * Auxiliary utilies on basic blocks *) + +(** ** A unified view of Kalray instructions *) + +Inductive instruction : Type := + | PBasic (i: basic) + | PControl (i: control) +. + +Coercion PBasic: basic >-> instruction. +Coercion PControl: control >-> instruction. + +Definition code := list instruction. +Definition bcode := list basic. + +Fixpoint basics_to_code (l: list basic) := + match l with + | nil => nil + | bi::l => (PBasic bi)::(basics_to_code l) + end. + +Fixpoint code_to_basics (c: code) := + match c with + | (PBasic i)::c => + match code_to_basics c with + | None => None + | Some l => Some (i::l) + end + | _::c => None + | nil => Some nil + end. + +Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. +Proof. + intros. induction c as [|i c]; simpl; auto. + rewrite IHc. auto. +Qed. + +Lemma code_to_basics_dist: + forall c c' l l', + code_to_basics c = Some l -> + code_to_basics c' = Some l' -> + code_to_basics (c ++ c') = Some (l ++ l'). +Proof. + induction c as [|i c]; simpl; auto. + - intros. inv H. simpl. auto. + - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. + inv H. erewrite IHc; eauto. auto. +Qed. + +(** + Asmblockgen will have to translate a Mach control into a list of instructions of the form + i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction + These functions provide way to extract the basic / control instructions +*) + +Fixpoint extract_basic (c: code) := + match c with + | nil => nil + | PBasic i :: c => i :: (extract_basic c) + | PControl i :: c => nil + end. + +Fixpoint extract_ctl (c: code) := + match c with + | nil => None + | PBasic i :: c => extract_ctl c + | PControl i :: nil => Some i + | PControl i :: _ => None (* if the first found control instruction isn't the last *) + end. + +(** ** Wellformness of basic blocks *) + +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +Definition non_empty_bblock (body: list basic) (exit: option control): Prop + := body <> nil \/ exit <> None. + +Lemma non_empty_bblock_refl: + forall body exit, + non_empty_bblock body exit <-> + Is_true (non_empty_bblockb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. intros. inversion H; contradiction. + - destruct body; destruct exit. + all: simpl; auto. + all: intros; try (right; discriminate); try (left; discriminate). + contradiction. +Qed. + +Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, + exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. + + +Lemma builtin_alone_refl: + forall body exit, + builtin_alone body exit <-> Is_true (builtin_aloneb body exit). +Proof. + intros. split. + - destruct body; destruct exit. + all: simpl; auto. + all: exploreInst; simpl; auto. + unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. + assert (b :: body = nil). eapply H; eauto. discriminate. + - destruct body; destruct exit. + all: simpl; auto; try constructor. + + exploreInst; try discriminate. + simpl. contradiction. + + intros. discriminate. +Qed. + +Definition wf_bblock (body: list basic) (exit: option control) := + non_empty_bblock body exit /\ builtin_alone body exit. + +Lemma wf_bblock_refl: + forall body exit, + wf_bblock body exit <-> Is_true (wf_bblockb body exit). +Proof. + intros. split. + - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + apply andb_prop_intro. auto. + - intros. apply andb_prop_elim in H. inv H. + apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. + unfold wf_bblock. split; auto. +Qed. + +Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). + +Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2. +Proof. + destruct b; simpl; auto. + - destruct p1, p2; auto. + - destruct p1. +Qed. + +Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. +Proof. + destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. + intros; subst. + rewrite (Istrue_proof_irrelevant _ c1 c2). + auto. +Qed. + +Program Definition bblock_single_inst (i: instruction) := + match i with + | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} + | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + right. discriminate. + constructor. +Qed. + +Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. +Proof. + intros. destruct l; try (contradict H; auto; fail). + simpl. omega. +Qed. + +Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. +Proof. + intros. destruct z; auto. + - contradict H. simpl. apply gt_irrefl. + - apply Zgt_pos_0. + - contradict H. simpl. apply gt_irrefl. +Qed. + +Lemma size_positive (b:bblock): size b > 0. +Proof. + unfold size. destruct b as [hd bdy ex cor]. simpl. + destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). + inversion cor; contradict H; simpl; auto. +Qed. + + +Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma no_header_size: + forall bb, size (no_header bb) = size bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. +Qed. + +Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. +Next Obligation. + destruct bb; simpl. assumption. +Defined. + +Lemma stick_header_size: + forall h bb, size (stick_header h bb) = size bb. +Proof. + intros. destruct bb. unfold stick_header. simpl. reflexivity. +Qed. + +Lemma stick_header_no_header: + forall bb, stick_header (header bb) (no_header bb) = bb. +Proof. + intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. +Qed. + +(** * Sequential Semantics of basic blocks *) +Section RELSEM. + +(** Execution of arith instructions *) + +Variable ge: genv. + +Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec_arith_instr ge ai rs rs. + +(** Auxiliaries for memory accesses *) + +Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs. + +Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro. + +Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro. + +Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. + +Definition exec_load_o_offset (rs: regset) (m: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := parexec_load_o_offset rs rs m m d a ofs. + +Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. + +Definition exec_store_q_offset (rs: regset) (m: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := parexec_store_q_offset rs rs m m s a ofs. + +Definition exec_store_o_offset (rs: regset) (m: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := parexec_store_o_offset rs rs m m s a ofs. + +Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. + +Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_regxs chunk rs rs m m s a ro. + +(** * basic instructions *) + +Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := bstep ge bi rs rs m m. + +Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := + match body with + | nil => Next rs m + | bi::body' => + match exec_basic_instr bi rs m with + | Next rs' m' => exec_body body' rs' m' + | Stuck => Stuck + end + end. + + +Theorem builtin_body_nil: + forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. +Proof. + intros. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. + eapply H1; eauto. +Qed. + +Theorem exec_body_app: + forall l l' rs m rs'' m'', + exec_body (l ++ l') rs m = Next rs'' m'' -> + exists rs' m', + exec_body l rs m = Next rs' m' + /\ exec_body l' rs' m' = Next rs'' m''. +Proof. + induction l. + - intros. simpl in H. repeat eexists. auto. + - intros. rewrite <- app_comm_cons in H. simpl in H. + destruct (exec_basic_instr a rs m) eqn:EXEBI. + + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). + repeat eexists. simpl. rewrite EXEBI. eauto. auto. + + discriminate. +Qed. + +(** Position corresponding to a label *) + +Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. + +Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. + +Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. + +Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := + match exec_body (body b) rs0 m with + | Next rs' m' => + let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' + | Stuck => Stuck + end. + + +(** Execution of the instruction at [rs PC]. *) + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bi rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> + exec_bblock f bi rs m = Next rs' m' -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' bi, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextblock bi + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#RTMP <- Vundef))) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> + step (State rs m) t (State rs' m') + . + +End RELSEM. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +Definition data_preg (r: preg) : bool := + match r with + | RA => false + | IR GPRA => false + | IR RTMP => false + | IR _ => true + | PC => false + end. diff --git a/kvx/Asmblockdeps.v b/kvx/Asmblockdeps.v new file mode 100644 index 00000000..1881e7e9 --- /dev/null +++ b/kvx/Asmblockdeps.v @@ -0,0 +1,1833 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Translation from Asmblock to AbstractBB + + We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance + AbstractBB will then define two semantics for L : a sequential, and a semantic one + We prove a bisimulation between the parallel semantics of L and AsmVLIW + From this, we also deduce a bisimulation between the sequential semantics of L and Asmblock *) + +Require Import AST. +Require Import Asmblock. +Require Import Asmblockgenproof0 Asmblockprops. +Require Import Values. +Require Import Globalenvs. +Require Import Memory. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import ZArith. +Require Import Coqlib. +Require Import ImpSimuTest. +Require Import Axioms. +Require Import Parallelizability. +Require Import Asmvliw Permutation. +Require Import Chunks. + +Require Import Lia. + +Open Scope impure. + +(** Definition of L *) + +Module P<: ImpParam. +Module R := Pos. + +Section IMPPARAM. + +Definition env := Genv.t fundef unit. + +Inductive genv_wrap := Genv (ge: env) (fn: function). +Definition genv := genv_wrap. + +Variable Ge: genv. + +Inductive value_wrap := + | Val (v: val) + | Memstate (m: mem) +. + +Definition value := value_wrap. + +Inductive control_op := + | Oj_l (l: label) + | Ocb (bt: btest) (l: label) + | Ocbu (bt: btest) (l: label) + | Odiv + | Odivu + | OError + | OIncremPC (sz: Z) + | Ojumptable (l: list label) +. + +Inductive arith_op := + | OArithR (n: arith_name_r) + | OArithRR (n: arith_name_rr) + | OArithRI32 (n: arith_name_ri32) (imm: int) + | OArithRI64 (n: arith_name_ri64) (imm: int64) + | OArithRF32 (n: arith_name_rf32) (imm: float32) + | OArithRF64 (n: arith_name_rf64) (imm: float) + | OArithRRR (n: arith_name_rrr) + | OArithRRI32 (n: arith_name_rri32) (imm: int) + | OArithRRI64 (n: arith_name_rri64) (imm: int64) + | OArithARRR (n: arith_name_arrr) + | OArithARR (n: arith_name_arr) + | OArithARRI32 (n: arith_name_arri32) (imm: int) + | OArithARRI64 (n: arith_name_arri64) (imm: int64) +. + +Coercion OArithR: arith_name_r >-> arith_op. +Coercion OArithRR: arith_name_rr >-> arith_op. +Coercion OArithRI32: arith_name_ri32 >-> Funclass. +Coercion OArithRI64: arith_name_ri64 >-> Funclass. +Coercion OArithRF32: arith_name_rf32 >-> Funclass. +Coercion OArithRF64: arith_name_rf64 >-> Funclass. +Coercion OArithRRR: arith_name_rrr >-> arith_op. +Coercion OArithRRI32: arith_name_rri32 >-> Funclass. +Coercion OArithRRI64: arith_name_rri64 >-> Funclass. + +Inductive load_op := + | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset) + | OLoadRRR (n: load_name) (trap: trapping_mode) + | OLoadRRRXS (n: load_name) (trap: trapping_mode) +. + +Coercion OLoadRRO: load_name >-> Funclass. + +Inductive store_op := + | OStoreRRO (n: store_name) (ofs: offset) + | OStoreRRR (n: store_name) + | OStoreRRRXS (n: store_name) +. + +Coercion OStoreRRO: store_name >-> Funclass. + +Inductive op_wrap := + | Arith (ao: arith_op) + | Load (lo: load_op) + | Store (so: store_op) + | Control (co: control_op) + | Allocframe (sz: Z) (pos: ptrofs) + | Allocframe2 (sz: Z) (pos: ptrofs) + | Freeframe (sz: Z) (pos: ptrofs) + | Freeframe2 (sz: Z) (pos: ptrofs) + | Constant (v: val) + | Fail +. + +Coercion Arith: arith_op >-> op_wrap. +Coercion Load: load_op >-> op_wrap. +Coercion Store: store_op >-> op_wrap. +Coercion Control: control_op >-> op_wrap. + +Definition op := op_wrap. + +Definition arith_eval (ao: arith_op) (l: list value) := + let (ge, fn) := Ge in + match ao, l with + | OArithR n, [] => Some (Val (arith_eval_r ge n)) + + | OArithRR n, [Val v] => Some (Val (arith_eval_rr n v)) + + | OArithRI32 n i, [] => Some (Val (arith_eval_ri32 n i)) + | OArithRI64 n i, [] => Some (Val (arith_eval_ri64 n i)) + | OArithRF32 n i, [] => Some (Val (arith_eval_rf32 n i)) + | OArithRF64 n i, [] => Some (Val (arith_eval_rf64 n i)) + + | OArithRRR n, [Val v1; Val v2] => Some (Val (arith_eval_rrr n v1 v2)) + | OArithRRI32 n i, [Val v] => Some (Val (arith_eval_rri32 n v i)) + | OArithRRI64 n i, [Val v] => Some (Val (arith_eval_rri64 n v i)) + + | OArithARR n, [Val v1; Val v2] => Some (Val (arith_eval_arr n v1 v2)) + | OArithARRR n, [Val v1; Val v2; Val v3] => Some (Val (arith_eval_arrr n v1 v2 v3)) + | OArithARRI32 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri32 n v1 v2 i)) + | OArithARRI64 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri64 n v1 v2 i)) + + | _, _ => None + end. + +Definition exec_incorrect_load trap chunk := + match trap with + | TRAP => None + | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk)) + end. + +Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := + let (ge, fn) := Ge in + match (eval_offset ofs) with + | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with + | None => exec_incorrect_load trap chunk + | Some vl => Some (Val vl) + end + | _ => None + end. + +Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := + match Mem.loadv chunk m (Val.addl v vo) with + | None => exec_incorrect_load trap chunk + | Some vl => Some (Val vl) + end. + +Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := + match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with + | None => exec_incorrect_load trap chunk + | Some vl => Some (Val vl) + end. + +Definition load_eval (lo: load_op) (l: list value) := + match lo, l with + | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs + | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo + | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo + | _, _ => None + end. + +Definition exec_store_deps_offset (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := + let (ge, fn) := Ge in + match (eval_offset ofs) with + | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with + | None => None + | Some m' => Some (Memstate m') + end + | _ => None + end. + +Definition exec_store_deps_reg (chunk: memory_chunk) (m: mem) (vs va vo: val) := + match Mem.storev chunk m (Val.addl va vo) vs with + | None => None + | Some m' => Some (Memstate m') + end. + +Definition exec_store_deps_regxs (chunk: memory_chunk) (m: mem) (vs va vo: val) := + match Mem.storev chunk m (Val.addl va (Val.shll vo (scale_of_chunk chunk))) vs with + | None => None + | Some m' => Some (Memstate m') + end. + +Definition store_eval (so: store_op) (l: list value) := + match so, l with + | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps_offset (store_chunk n) m vs va ofs + | OStoreRRR n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_reg (store_chunk n) m vs va vo + | OStoreRRRXS n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_regxs (store_chunk n) m vs va vo + | _, _ => None + end. + +Local Open Scope Z. + +Remark size_chunk_positive: forall chunk, + (size_chunk chunk) > 0. +Proof. + destruct chunk; simpl; lia. +Qed. + +Remark size_chunk_small: forall chunk, + (size_chunk chunk) <= 8. +Proof. + destruct chunk; simpl; lia. +Qed. + +Definition disjoint_chunks + (ofs1 : offset) (chunk1 : memory_chunk) + (ofs2 : offset) (chunk2 : memory_chunk) := + Intv.disjoint ((Ptrofs.unsigned ofs1), + ((Ptrofs.unsigned ofs1) + (size_chunk chunk1))) + ((Ptrofs.unsigned ofs2), + ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). + +Definition small_offset_threshold := 18446744073709551608. + +Lemma store_store_disjoint_offsets : + forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> + store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> + store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> + m2 = m2'. +Proof. + intros until m2'. + intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'. + unfold disjoint_chunks in DISJOINT. + destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. + destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + destruct Ge. + unfold eval_offset in *; simpl in *. + unfold Mem.storev in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. + inv STORE0. + destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. + inv STORE1. + destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. + inv STORE0'. + destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. + inv STORE1'. + assert (Some m2 = Some m2'). + 2: congruence. + rewrite <- E1. + rewrite <- E1'. + eapply Mem.store_store_other. + 2, 3: eassumption. + + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (store_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (store_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1, 2: lia. + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. +Qed. + +Lemma load_store_disjoint_offsets : + forall n1 n2 tm ofs1 ofs2 vs va m0 m1, + (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) -> + (Ptrofs.unsigned ofs1) < small_offset_threshold -> + (Ptrofs.unsigned ofs2) < small_offset_threshold -> + store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) -> + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] = + load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0]. +Proof. + intros until m1. + intros DISJOINT SMALL1 SMALL2 STORE0. + destruct vs as [v | ]; simpl in STORE0; try congruence. + destruct va as [base | ]; try congruence. + unfold exec_store_deps_offset in *. + unfold eval_offset in *; simpl in *. + unfold exec_load_deps_offset. + unfold Mem.storev, Mem.loadv in *. + destruct Ge in *. + unfold eval_offset in *. + unfold Val.offset_ptr in *. + destruct base as [ | | | | | wblock wpofs] in * ; try congruence. + destruct (Mem.store _ _ _ _) eqn:E0; try congruence. + inv STORE0. + assert ( + (Mem.load (load_chunk n2) m1 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) = + (Mem.load (load_chunk n2) m0 wblock + (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS. + { + eapply Mem.load_store_other. + eassumption. + right. + pose proof (size_chunk_positive (store_chunk n1)). + pose proof (size_chunk_positive (load_chunk n2)). + pose proof (size_chunk_small (store_chunk n1)). + pose proof (size_chunk_small (load_chunk n2)). + destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; + unfold Intv.empty in DIS; simpl in DIS. + 1,2: lia. + + pose proof (Ptrofs.unsigned_range ofs1). + pose proof (Ptrofs.unsigned_range ofs2). + unfold small_offset_threshold in *. + destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; + destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; + change Ptrofs.modulus with 18446744073709551616 in *; + lia. + } + destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. +Qed. + +Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := + match label_pos lbl 0 (fn_blocks f) with + | None => None + | Some pos => + match vpc with + | Vptr b ofs => Some (Val (Vptr b (Ptrofs.repr pos))) + | _ => None + end + end. + +Definition eval_branch_deps (f: function) (l: label) (vpc: val) (res: option bool) := + match res with + | Some true => goto_label_deps f l vpc + | Some false => Some (Val vpc) + | None => None + end. + +Definition control_eval (o: control_op) (l: list value) := + let (ge, fn) := Ge in + match o, l with + | (Ojumptable tbl), [Val index; Val vpc] => + match index with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => None + | Some lbl => goto_label_deps fn lbl vpc + end + | _ => None + end + | Oj_l l, [Val vpc] => goto_label_deps fn l vpc + | Ocb bt l, [Val v; Val vpc] => + match cmp_for_btest bt with + | (Some c, Int) => eval_branch_deps fn l vpc (Val.cmp_bool c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmpl_bool c v (Vlong (Int64.repr 0))) + | (None, _) => None + end + | Ocbu bt l, [Val v; Val vpc] => + match cmpu_for_btest bt with + | (Some c, Int) => eval_branch_deps fn l vpc (Val_cmpu_bool c v (Vint (Int.repr 0))) + | (Some c, Long) => eval_branch_deps fn l vpc (Val_cmplu_bool c v (Vlong (Int64.repr 0))) + | (None, _) => None + end + | Odiv, [Val v1; Val v2] => + match Val.divs v1 v2 with + | Some v => Some (Val v) + | None => None + end + | Odivu, [Val v1; Val v2] => + match Val.divu v1 v2 with + | Some v => Some (Val v) + | None => None + end + | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) + | OError, _ => None + | _, _ => None + end. + +Definition op_eval (o: op) (l: list value) := + match o, l with + | Arith o, l => arith_eval o l + | Load o, l => load_eval o l + | Store o, l => store_eval o l + | Control o, l => control_eval o l + | Allocframe sz pos, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with + | None => None + | Some m => Some (Memstate m) + end + | Allocframe2 sz pos, [Val spv; Memstate m] => + let (m1, stk) := Mem.alloc m 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with + | None => None + | Some m => Some (Val sp) + end + | Freeframe sz pos, [Val spv; Memstate m] => + match Mem.loadv Mptr m (Val.offset_ptr spv pos) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (Memstate m') + end + | _ => None + end + end + | Freeframe2 sz pos, [Val spv; Memstate m] => + match Mem.loadv Mptr m (Val.offset_ptr spv pos) with + | None => None + | Some v => + match spv with + | Vptr stk ofs => + match Mem.free m stk 0 sz with + | None => None + | Some m' => Some (Val v) + end + | _ => None + end + end + | Constant v, [] => Some (Val v) + | Fail, _ => None + | _, _ => None + end. + + +Definition arith_op_eq (o1 o2: arith_op): ?? bool := + match o1 with + | OArithR n1 => + match o2 with OArithR n2 => struct_eq n1 n2 | _ => RET false end + | OArithRR n1 => + match o2 with OArithRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithRI32 n1 i1 => + match o2 with OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRI64 n1 i1 => + match o2 with OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRF32 n1 i1 => + match o2 with OArithRF32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRF64 n1 i1 => + match o2 with OArithRF64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRRR n1 => + match o2 with OArithRRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithRRI32 n1 i1 => + match o2 with OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithRRI64 n1 i1 => + match o2 with OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithARRR n1 => + match o2 with OArithARRR n2 => phys_eq n1 n2 | _ => RET false end + | OArithARR n1 => + match o2 with OArithARR n2 => phys_eq n1 n2 | _ => RET false end + | OArithARRI32 n1 i1 => + match o2 with OArithARRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + | OArithARRI64 n1 i1 => + match o2 with OArithARRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end + end. + +Ltac my_wlp_simplify := wlp_xsimplify ltac:(intros; subst; simpl in * |- *; congruence || intuition eauto with wlp). + +Lemma arith_op_eq_correct o1 o2: + WHEN arith_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; my_wlp_simplify; try congruence. +Qed. +Hint Resolve arith_op_eq_correct: wlp. +Opaque arith_op_eq_correct. + +Definition offset_eq (ofs1 ofs2 : offset): ?? bool := + RET (Ptrofs.eq ofs1 ofs2). + +Lemma offset_eq_correct ofs1 ofs2: + WHEN offset_eq ofs1 ofs2 ~> b THEN b = true -> ofs1 = ofs2. +Proof. + wlp_simplify. + pose (Ptrofs.eq_spec ofs1 ofs2). + rewrite H in *. + trivial. +Qed. +Hint Resolve offset_eq_correct: wlp. + +Definition trapping_mode_eq trap1 trap2 := + RET (match trap1, trap2 with + | TRAP, TRAP | NOTRAP, NOTRAP => true + | TRAP, NOTRAP | NOTRAP, TRAP => false + end). +Lemma trapping_mode_eq_correct t1 t2: + WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2. +Proof. + wlp_simplify. + destruct t1; destruct t2; trivial; discriminate. +Qed. +Hint Resolve trapping_mode_eq_correct: wlp. + +Definition load_op_eq (o1 o2: load_op): ?? bool := + match o1 with + | OLoadRRO n1 trap ofs1 => + match o2 with + | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2)) + | _ => RET false + end + | OLoadRRR n1 trap => + match o2 with + | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end + | OLoadRRRXS n1 trap => + match o2 with + | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) + | _ => RET false + end + end. + +Lemma load_op_eq_correct o1 o2: + WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; try discriminate. + { f_equal. + destruct trap, trap0; simpl in *; trivial; discriminate. + pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. } + all: destruct trap, trap0; simpl in *; trivial; discriminate. +Qed. +Hint Resolve load_op_eq_correct: wlp. +Opaque load_op_eq_correct. + +Definition store_op_eq (o1 o2: store_op): ?? bool := + match o1 with + | OStoreRRO n1 ofs1 => + match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end + | OStoreRRR n1 => + match o2 with OStoreRRR n2 => phys_eq n1 n2 | _ => RET false end + | OStoreRRRXS n1 => + match o2 with OStoreRRRXS n2 => phys_eq n1 n2 | _ => RET false end + end. + +Lemma store_op_eq_correct o1 o2: + WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; try discriminate. + - f_equal. pose (Ptrofs.eq_spec ofs ofs0). + rewrite H in *. trivial. + - congruence. + - congruence. +Qed. +Hint Resolve store_op_eq_correct: wlp. +Opaque store_op_eq_correct. + +Definition control_op_eq (c1 c2: control_op): ?? bool := + match c1 with + | Oj_l l1 => + match c2 with Oj_l l2 => phys_eq l1 l2 | _ => RET false end + | Ocb bt1 l1 => + match c2 with Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end + | Ocbu bt1 l1 => + match c2 with Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end + | Ojumptable tbl1 => + match c2 with Ojumptable tbl2 => phys_eq tbl1 tbl2 | _ => RET false end + | Odiv => + match c2 with Odiv => RET true | _ => RET false end + | Odivu => + match c2 with Odivu => RET true | _ => RET false end + | OIncremPC sz1 => + match c2 with OIncremPC sz2 => RET (Z.eqb sz1 sz2) | _ => RET false end + | OError => + match c2 with OError => RET true | _ => RET false end + end. + +Lemma control_op_eq_correct c1 c2: + WHEN control_op_eq c1 c2 ~> b THEN b = true -> c1 = c2. +Proof. + destruct c1, c2; wlp_simplify; try rewrite Z.eqb_eq in * |-; try congruence. +Qed. +Hint Resolve control_op_eq_correct: wlp. +Opaque control_op_eq_correct. + +Definition op_eq (o1 o2: op): ?? bool := + match o1 with + | Arith i1 => + match o2 with Arith i2 => arith_op_eq i1 i2 | _ => RET false end + | Load i1 => + match o2 with Load i2 => load_op_eq i1 i2 | _ => RET false end + | Store i1 => + match o2 with Store i2 => store_op_eq i1 i2 | _ => RET false end + | Control i1 => + match o2 with Control i2 => control_op_eq i1 i2 | _ => RET false end + | Allocframe sz1 pos1 => + match o2 with Allocframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Allocframe2 sz1 pos1 => + match o2 with Allocframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Freeframe sz1 pos1 => + match o2 with Freeframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Freeframe2 sz1 pos1 => + match o2 with Freeframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end + | Constant c1 => + match o2 with Constant c2 => phys_eq c1 c2 | _ => RET false end + | Fail => + match o2 with Fail => RET true | _ => RET false end + end. + +Theorem op_eq_correct o1 o2: + WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. +Proof. + destruct o1, o2; wlp_simplify; try rewrite Z.eqb_eq in * |- ; try congruence. +Qed. +Hint Resolve op_eq_correct: wlp. +Global Opaque op_eq_correct. + +End IMPPARAM. + +End P. + +Module L <: ISeqLanguage with Module LP:=P. + +Module LP:=P. + +Include MkSeqLanguage P. + +End L. + +Module IST := ImpSimu L ImpPosDict. + +Import L. +Import P. + +(** Compilation from Asmblock to L *) + +Local Open Scope positive_scope. + +Definition pmem : R.t := 1. + +Definition ireg_to_pos (ir: ireg) : R.t := + match ir with + | GPR0 => 1 | GPR1 => 2 | GPR2 => 3 | GPR3 => 4 | GPR4 => 5 | GPR5 => 6 | GPR6 => 7 | GPR7 => 8 | GPR8 => 9 | GPR9 => 10 + | GPR10 => 11 | GPR11 => 12 | GPR12 => 13 | GPR13 => 14 | GPR14 => 15 | GPR15 => 16 | GPR16 => 17 | GPR17 => 18 | GPR18 => 19 | GPR19 => 20 + | GPR20 => 21 | GPR21 => 22 | GPR22 => 23 | GPR23 => 24 | GPR24 => 25 | GPR25 => 26 | GPR26 => 27 | GPR27 => 28 | GPR28 => 29 | GPR29 => 30 + | GPR30 => 31 | GPR31 => 32 | GPR32 => 33 | GPR33 => 34 | GPR34 => 35 | GPR35 => 36 | GPR36 => 37 | GPR37 => 38 | GPR38 => 39 | GPR39 => 40 + | GPR40 => 41 | GPR41 => 42 | GPR42 => 43 | GPR43 => 44 | GPR44 => 45 | GPR45 => 46 | GPR46 => 47 | GPR47 => 48 | GPR48 => 49 | GPR49 => 50 + | GPR50 => 51 | GPR51 => 52 | GPR52 => 53 | GPR53 => 54 | GPR54 => 55 | GPR55 => 56 | GPR56 => 57 | GPR57 => 58 | GPR58 => 59 | GPR59 => 60 + | GPR60 => 61 | GPR61 => 62 | GPR62 => 63 | GPR63 => 64 + end +. + +Lemma ireg_to_pos_discr: forall r r', r <> r' -> ireg_to_pos r <> ireg_to_pos r'. +Proof. + destruct r; destruct r'; try contradiction; discriminate. +Qed. + +Definition ppos (r: preg) : R.t := + match r with + | RA => 2 + | PC => 3 + | IR ir => 3 + ireg_to_pos ir + end +. + +Notation "# r" := (ppos r) (at level 100, right associativity). + +Lemma not_eq_add: + forall k n n', n <> n' -> k + n <> k + n'. +Proof. + intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. +Qed. + +Lemma ppos_discr: forall r r', r <> r' -> ppos r <> ppos r'. +Proof. + destruct r; destruct r'. + all: try discriminate; try contradiction. + - intros. apply not_eq_add. apply ireg_to_pos_discr. congruence. + - intros. unfold ppos. cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. + apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + - intros. unfold ppos. rewrite Pos.add_comm. apply Pos.add_no_neutral. + - intros. unfold ppos. apply not_eq_sym. + cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. + apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. + - intros. unfold ppos. apply not_eq_sym. rewrite Pos.add_comm. apply Pos.add_no_neutral. +Qed. + +Lemma ppos_pmem_discr: forall r, pmem <> ppos r. +Proof. + intros. destruct r. + - unfold ppos. unfold pmem. apply not_eq_sym. rewrite Pos.add_comm. cutrewrite (3 = 2 + 1). rewrite Pos.add_assoc. apply Pos.add_no_neutral. + reflexivity. + - unfold ppos. unfold pmem. discriminate. + - unfold ppos. unfold pmem. discriminate. +Qed. + +(** Inversion functions, used for debug traces *) + +Definition pos_to_ireg (p: R.t) : option gpreg := + match p with + | 1 => Some GPR0 | 2 => Some GPR1 | 3 => Some GPR2 | 4 => Some GPR3 | 5 => Some GPR4 | 6 => Some GPR5 | 7 => Some GPR6 | 8 => Some GPR7 | 9 => Some GPR8 | 10 => Some GPR9 + | 11 => Some GPR10 | 12 => Some GPR11 | 13 => Some GPR12 | 14 => Some GPR13 | 15 => Some GPR14 | 16 => Some GPR15 | 17 => Some GPR16 | 18 => Some GPR17 | 19 => Some GPR18 | 20 => Some GPR19 + | 21 => Some GPR20 | 22 => Some GPR21 | 23 => Some GPR22 | 24 => Some GPR23 | 25 => Some GPR24 | 26 => Some GPR25 | 27 => Some GPR26 | 28 => Some GPR27 | 29 => Some GPR28 | 30 => Some GPR29 + | 31 => Some GPR30 | 32 => Some GPR31 | 33 => Some GPR32 | 34 => Some GPR33 | 35 => Some GPR34 | 36 => Some GPR35 | 37 => Some GPR36 | 38 => Some GPR37 | 39 => Some GPR38 | 40 => Some GPR39 + | 41 => Some GPR40 | 42 => Some GPR41 | 43 => Some GPR42 | 44 => Some GPR43 | 45 => Some GPR44 | 46 => Some GPR45 | 47 => Some GPR46 | 48 => Some GPR47 | 49 => Some GPR48 | 50 => Some GPR49 + | 51 => Some GPR50 | 52 => Some GPR51 | 53 => Some GPR52 | 54 => Some GPR53 | 55 => Some GPR54 | 56 => Some GPR55 | 57 => Some GPR56 | 58 => Some GPR57 | 59 => Some GPR58 | 60 => Some GPR59 + | 61 => Some GPR60 | 62 => Some GPR61 | 63 => Some GPR62 | 64 => Some GPR63 + | _ => None + end. + +Definition inv_ppos (p: R.t) : option preg := + match p with + | 1 => None + | 2 => Some RA | 3 => Some PC + | n => match pos_to_ireg (n-3) with + | None => None + | Some gpr => Some (IR gpr) + end + end. + +Notation "a @ b" := (Econs a b) (at level 102, right associativity). + +Definition trans_control (ctl: control) : inst := + match ctl with + | Pret => [(#PC, PReg(#RA))] + | Pcall s => [(#RA, PReg(#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] + | Picall r => [(#RA, PReg(#PC)); (#PC, PReg(#r))] + | Pgoto s => [(#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] + | Pigoto r => [(#PC, PReg(#r))] + | Pj_l l => [(#PC, Op (Control (Oj_l l)) (PReg(#PC) @ Enil))] + | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] + | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (PReg(#r) @ PReg(#PC) @ Enil)); + (#GPR62, Op (Constant Vundef) Enil); + (#GPR63, Op (Constant Vundef) Enil) ] + | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] + end. + +Definition trans_exit (ex: option control) : L.inst := + match ex with + | None => [] + | Some ctl => trans_control ctl + end +. + +Definition trans_arith (ai: ar_instruction) : inst := + match ai with + | PArithR n d => [(#d, Op (Arith (OArithR n)) Enil)] + | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (PReg(#s) @ Enil))] + | PArithRI32 n d i => [(#d, Op (Arith (OArithRI32 n i)) Enil)] + | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] + | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] + | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] + | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (PReg(#s1) @ PReg(#s2) @ Enil))] + | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (PReg(#s) @ Enil))] + | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (PReg(#s) @ Enil))] + | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (PReg(#d) @ PReg(#s1) @ PReg(#s2) @ Enil))] + | PArithARR n d s => [(#d, Op (Arith (OArithARR n)) (PReg(#d) @ PReg(#s) @ Enil))] + | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (PReg(#d) @ PReg(#s) @ Enil))] + | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (PReg(#d) @ PReg(#s) @ Enil))] + end. + + +Definition trans_basic (b: basic) : inst := + match b with + | PArith ai => trans_arith ai + | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))] + | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] + | PLoadQRRO qd a ofs => + let (d0, d1) := gpreg_q_expand qd in + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + | PLoadORRO od a ofs => + match gpreg_o_expand od with + | (d0, d1, d2, d3) => + [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); + (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); + (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] + end + | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] + | PStoreQRRO qs a ofs => + let (s0, s1) := gpreg_q_expand qs in + [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] + | PStoreORRO os a ofs => + match gpreg_o_expand os with + | (s0, s1, s2, s3) => + [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (PReg (#s2) @ PReg (#a) @ PReg pmem @ Enil)); + (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (PReg (#s3) @ PReg (#a) @ PReg pmem @ Enil))] + end + | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); + (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] + | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); + (#SP, Op (Freeframe2 sz pos) (PReg (#SP) @ Old (PReg pmem) @ Enil)); + (#RTMP, Op (Constant Vundef) Enil)] + | Pget rd ra => match ra with + | RA => [(#rd, PReg(#ra))] + | _ => [(#rd, Op Fail Enil)] + end + | Pset ra rd => match ra with + | RA => [(#ra, PReg(#rd))] + | _ => [(#rd, Op Fail Enil)] + end + | Pnop => [] + end. + +Fixpoint trans_body (b: list basic) : list L.inst := + match b with + | nil => nil + | b :: lb => (trans_basic b) :: (trans_body lb) + end. + +Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (PReg(#PC) @ Enil)) :: k. + +Definition trans_block (b: Asmvliw.bblock) : L.bblock := + trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). + +Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. +Proof. + intros. destruct bb as [hd bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. +Qed. + +Theorem trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. +Proof. + intros. destruct bb as [hdr bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. +Qed. + +Definition state := L.mem. +Definition exec := L.run. + +Definition match_states (s: Asmvliw.state) (s': state) := + let (rs, m) := s in + s' pmem = Memstate m + /\ forall r, s' (#r) = Val (rs r). + +Definition match_outcome (o:outcome) (s: option state) := + match o with + | Next rs m => exists s', s=Some s' /\ match_states (State rs m) s' + | Stuck => s=None + end. + +Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). + +Definition trans_state (s: Asmvliw.state) : state := + let (rs, m) := s in + fun x => if (Pos.eq_dec x pmem) then Memstate m + else match (inv_ppos x) with + | Some r => Val (rs r) + | None => Val Vundef + end. + +Lemma not_eq_IR: + forall r r', r <> r' -> IR r <> IR r'. +Proof. + intros. congruence. +Qed. + +(** Parallelizability test of a bblock (bundle), and bisimulation of the Asmblock and L parallel semantics *) + +Module PChk := ParallelChecks L PosPseudoRegSet. + +Definition bblock_para_check (p: Asmvliw.bblock) : bool := + PChk.is_parallelizable (trans_block p). + +Section SECT_PAR. + +Import PChk. + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + || (rewrite assign_diff by (auto; try discriminate; try (apply ppos_discr; try discriminate; congruence); try (apply ppos_pmem_discr); + try (apply not_eq_sym; apply ppos_discr; try discriminate; congruence); try (apply not_eq_sym; apply ppos_pmem_discr); auto)) + || (rewrite assign_eq) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +Arguments Pos.add: simpl never. +Arguments ppos: simpl never. + +Variable Ge: genv. + +Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + parexec_arith_instr ge i rsr rsw = rsw' -> + exists sw', + inst_prun Ge (trans_arith i) sw sr sr = Some sw' + /\ match_states (State rsw' mw) sw'. +Proof. + intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. + unfold parexec_arith_instr. destruct i. +(* Ploadsymbol *) + - destruct i. eexists; split; [| split]. + * simpl. reflexivity. + * Simpl. + * simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRR *) + - eexists; split; [| split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRI32 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRI64 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF32 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRF64 *) + - eexists; split; [|split]. + * simpl. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRR *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRI32 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithRRI64 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRR *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARR *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRI32 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* PArithARRI64 *) + - eexists; split; [|split]. + * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +Qed. + + + +Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + match_outcome (bstep ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). +Proof. + +(* a little tactic to automate reasoning on preg_eq *) +Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. +Local Ltac preg_eq_discr r rd := + destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); + rewrite (assign_diff _ (#rd) (#r) _); auto; + rewrite Pregmap.gso; auto. + + intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). + destruct bi; simpl. +(* Arith *) + - exploit trans_arith_par_correct. 5: eauto. all: eauto. +(* Load *) + - destruct i. + (* Load Offset *) + + destruct i; simpl load_chunk. all: + unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; + unfold eval_offset; + simpl; auto; + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + + (* Load Reg *) + + destruct i; simpl load_chunk. all: + unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs); + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + + (* Load Reg XS *) + + destruct i; simpl load_chunk. all: + unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); + destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. + + (* Load Quad word *) + + unfold parexec_load_q_offset. + destruct (gpreg_q_expand rd) as [rd0 rd1]; destruct Ge; simpl. + rewrite H0, H. + destruct (Mem.loadv Many64 mr _) as [load0 | ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. + eexists; intuition eauto. + { rewrite !(assign_diff _ _ pmem); auto. } + { preg_eq_discr r rd1. + preg_eq_discr r rd0. } + + (* Load Octuple word *) + + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. + unfold parexec_load_o_offset. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. + rewrite H0, H. + destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 16)))) as [load2| ]; simpl; auto. + rewrite !(assign_diff _ _ pmem), !H; auto. + destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 24)))) as [load3| ]; simpl; auto. + eexists; intuition eauto. + { rewrite !(assign_diff _ _ pmem); auto. } + { preg_eq_discr r rd3. + preg_eq_discr r rd2. + preg_eq_discr r rd1. + preg_eq_discr r rd0. } + +(* Store *) + - destruct i. + (* Store Offset *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_offset; simpl; unfold exec_store_deps_offset; erewrite GENV, H, H0; rewrite (H0 ra); + unfold eval_offset; simpl; auto; + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. + + (* Store Reg *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_reg; simpl; unfold exec_store_deps_reg; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. + + (* Store Reg XS *) + + destruct i; simpl store_chunk. all: + unfold parexec_store_regxs; simpl; unfold exec_store_deps_regxs; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); + destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; + eexists; split; try split; Simpl; + intros rr; destruct rr; Simpl. + + (* Store Quad Word *) + + unfold parexec_store_q_offset. + destruct (gpreg_q_expand rs) as [s0 s1]; destruct Ge; simpl. + rewrite !H0, !H. + destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ]; simpl; auto. + eexists; intuition eauto. + rewrite !assign_diff; auto. + + (* Store Ocuple Word *) + + unfold parexec_store_o_offset. + destruct (gpreg_o_expand rs) as [[[s0 s1] s2] s3]; destruct Ge; simpl. + rewrite !H0, !H. + destruct (Mem.storev _ _ _ (rsr s0)) as [store0 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s1)) as [store1 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s2)) as [store2 | ]; simpl; auto. + rewrite !assign_diff, !H0; auto. + destruct (Mem.storev _ _ _ (rsr s3)) as [store3 | ]; simpl; auto. + eexists; intuition eauto. + rewrite !assign_diff; auto. + + (* Allocframe *) + - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. + * eexists; repeat split. + { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. + rewrite H, MEMAL. rewrite MEMS. reflexivity. } + { Simpl. } + { intros rr; destruct rr; Simpl. + destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. } + * simpl; Simpl; erewrite !H0, H, MEMAL, MEMS; auto. + (* Freeframe *) + - erewrite !H0, H. + destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto. + destruct (rsr GPR12) eqn:SPeq; simpl; auto. + destruct (Mem.free _ _ _ _) eqn:MFREE; simpl; auto. + eexists; repeat split. + * simpl. Simpl. erewrite H0, SPeq, MLOAD, MFREE. reflexivity. + * Simpl. + * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. +(* Pget *) + - destruct rs eqn:rseq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. + destruct (ireg_eq g rd); subst; Simpl. +(* Pset *) + - destruct rd eqn:rdeq; simpl; auto. + eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. +(* Pnop *) + - eexists. repeat split; assumption. +Qed. + + +Theorem bisimu_par_body: + forall bdy ge fn rsr mr sr rsw mw sw, + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + match_outcome (parexec_wio_body ge bdy rsr rsw mr mw) (prun_iw Ge (trans_body bdy) sw sr). +Proof. + induction bdy as [|i bdy]; simpl; eauto. + intros. + exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. + destruct (bstep _ _ _ _ _ _); simpl. + - intros (s' & X1 & X2). rewrite X1; simpl; eauto. + - intros X; rewrite X; simpl; auto. +Qed. + +Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) (rsw#PC <- aux) mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). +Proof. + intros GENV MSR MSW; unfold estep. + simpl in *. inv MSR. inv MSW. + destruct ex. + - destruct c; destruct i; try discriminate; simpl. + all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold incrPC; Simpl). + + (* Pjumptable *) + + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold incrPC. Simpl. + destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. + unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. + destruct (preg_eq g GPR62). rewrite e. Simpl. + destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. + + (* Pj_l *) + + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. + unfold incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. + eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. + + (* Pcb *) + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. + ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + + (* Pcbu *) + + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. + unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. + ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. + +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. + destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. + intros rr; destruct rr; Simpl. + +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. + + - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. + intros rr; destruct rr; unfold incrPC; Simpl. +Qed. + +Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_states (State rsw mw) sw -> + match_outcome (estep ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). +Proof. + intros; unfold estep. + exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. + cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. + apply extensionality. intros; destruct x; simpl; auto. +Qed. + +Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). + +Theorem bisimu_par_wio ge fn rsr mr sr bdy ex sz: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr). +Proof. + intros GENV MSR. unfold parexec_wio, trans_block_aux. + exploit (bisimu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. + destruct (parexec_wio_body _ _ _ _ _ _); simpl. + - intros (s' & X1 & X2). + erewrite prun_iw_app_Some; eauto. + exploit (bisimu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. + subst Ge; simpl. destruct MSR as (Y1 & Y2). erewrite Y2; simpl. + destruct (inst_prun _ _ _ _ _); simpl; auto. + - intros X; erewrite prun_iw_app_None; eauto. +Qed. + +Theorem bisimu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: + Ge = Genv ge fn -> + match_states (State rsr mr) sr -> + match_outcome + match parexec_wio ge fn bdy1 ex (Ptrofs.repr sz) rsr mr with + | Next rs' m' => parexec_wio_body ge bdy2 rsr rs' mr m' + | Stuck => Stuck + end + (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). +Proof. + intros. + exploit (bisimu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. + destruct (parexec_wio _ _ _ _ _ _); simpl. + - intros (s' & X1 & X2). + erewrite prun_iw_app_Some; eauto. + eapply bisimu_par_body; eauto. + - intros; erewrite prun_iw_app_None; eauto. +Qed. + +Lemma trans_body_perserves_permutation bdy1 bdy2: + Permutation bdy1 bdy2 -> + Permutation (trans_body bdy1) (trans_body bdy2). +Proof. + induction 1; simpl; econstructor; eauto. +Qed. + +Lemma trans_body_app bdy1: forall bdy2, + trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). +Proof. + induction bdy1; simpl; congruence. +Qed. + +Theorem trans_block_perserves_permutation bdy1 bdy2 b: + Permutation (bdy1 ++ bdy2) (body b) -> + Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). +Proof. + intro H; unfold trans_block, trans_block_aux. + eapply perm_trans. + - eapply Permutation_app_tail. + apply trans_body_perserves_permutation. + apply Permutation_sym; eapply H. + - rewrite trans_body_app. rewrite <-! app_assoc. + apply Permutation_app_head. + apply Permutation_app_comm. +Qed. + +Theorem bisimu_par rs1 m1 s1' b ge fn o2: + Ge = Genv ge fn -> + match_states (State rs1 m1) s1' -> + parexec_bblock ge fn b rs1 m1 o2 -> + exists o2', + prun Ge (trans_block b) s1' o2' + /\ match_outcome o2 o2'. +Proof. + intros GENV MS PAREXEC. + inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). + exploit trans_block_perserves_permutation; eauto. + intros Perm. + exploit (bisimu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. + rewrite <- WIO. clear WIO. + intros H; eexists; split. 2: eapply H. + unfold prun; eexists; split; eauto. + destruct (prun_iw _ _ _ _); simpl; eauto. +Qed. + +(** sequential execution *) +Theorem bisimu_basic ge fn bi rs m s: + Ge = Genv ge fn -> + match_states (State rs m) s -> + match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s). +Proof. + intros; unfold exec_basic_instr. rewrite inst_run_prun. + eapply bisimu_par_wio_basic; eauto. +Qed. + +Lemma bisimu_body: + forall bdy ge fn rs m s, + Ge = Genv ge fn -> + match_states (State rs m) s -> + match_outcome (exec_body ge bdy rs m) (exec Ge (trans_body bdy) s). +Proof. + induction bdy as [|i bdy]; simpl; eauto. + intros. + exploit (bisimu_basic ge fn i rs m s); eauto. + destruct (exec_basic_instr _ _ _ _); simpl. + - intros (s' & X1 & X2). rewrite X1; simpl; eauto. + - intros X; rewrite X; simpl; auto. +Qed. + +Theorem bisimu_exit ge fn b rs m s: + Ge = Genv ge fn -> + match_states (State rs m) s -> + match_outcome (exec_control ge fn (exit b) (nextblock b rs) m) (inst_run Ge (trans_pcincr (size b) (trans_exit (exit b))) s s). +Proof. + intros; unfold exec_control, nextblock. rewrite inst_run_prun. + apply (bisimu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. +Qed. + +Theorem bisimu rs m b ge fn s: + Ge = Genv ge fn -> + match_states (State rs m) s -> + match_outcome (exec_bblock ge fn b rs m) (exec Ge (trans_block b) s). +Proof. + intros GENV MS. unfold exec_bblock. + exploit (bisimu_body (body b) ge fn rs m s); eauto. + unfold exec, trans_block; simpl. + destruct (exec_body _ _ _ _); simpl. + - intros (s' & X1 & X2). + erewrite run_app_Some; eauto. + exploit (bisimu_exit ge fn b rs0 m0 s'); eauto. + subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl. + destruct (inst_run _ _ _); simpl; auto. + - intros X; erewrite run_app_None; eauto. +Qed. + + +Theorem trans_state_match: forall S, match_states S (trans_state S). +Proof. + intros. destruct S as (rs & m). simpl. + split. reflexivity. + intro. destruct r; try reflexivity. + destruct g; reflexivity. +Qed. + + +Lemma state_eq_decomp: + forall rs1 m1 rs2 m2, rs1 = rs2 -> m1 = m2 -> State rs1 m1 = State rs2 m2. +Proof. + intros. congruence. +Qed. + +Theorem state_equiv S1 S2 S': match_states S1 S' -> match_states S2 S' -> S1 = S2. +Proof. + unfold match_states; intros H0 H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. + apply state_eq_decomp. + - apply functional_extensionality. intros. assert (Val (rs1 x) = Val (rs2 x)) by congruence. congruence. + - congruence. +Qed. + +Lemma bblock_para_check_correct ge fn bb rs m rs' m': + Ge = Genv ge fn -> + exec_bblock ge fn bb rs m = Next rs' m' -> + bblock_para_check bb = true -> + det_parexec ge fn bb rs m rs' m'. +Proof. + intros H H0 H1 o H2. unfold bblock_para_check in H1. + exploit (bisimu rs m bb ge fn); eauto. eapply trans_state_match. + rewrite H0; simpl. + intros (s2' & EXEC & MS). + exploit bisimu_par. 2: apply (trans_state_match (State rs m)). all: eauto. + intros (o2' & PRUN & MO). + exploit parallelizable_correct. apply is_para_correct_aux. eassumption. + intro. eapply H3 in PRUN. clear H3. destruct o2'. + - inv PRUN. inv H3. unfold exec in EXEC; unfold trans_state in H. + assert (x = s2') by congruence. subst. clear H. + assert (m0 = s2') by (apply functional_extensionality; auto). subst. clear H4. + destruct o; try discriminate. inv MO. inv H. assert (s2' = x) by congruence. subst. + exploit (state_equiv (State rs' m') (State rs0 m0)). + 2: eapply H4. eapply MS. intro H. inv H. reflexivity. + - unfold match_outcome in MO. destruct o. + + inv MO. inv H3. discriminate. + + clear MO. unfold exec in EXEC. + unfold trans_state in PRUN; rewrite EXEC in PRUN. discriminate. +Qed. + +End SECT_PAR. + +Section SECT_BBLOCK_EQUIV. + +Variable Ge: genv. + +Local Hint Resolve trans_state_match: core. + +Lemma bblock_simu_reduce: + forall p1 p2 ge fn, + Ge = Genv ge fn -> + L.bblock_simu Ge (trans_block p1) (trans_block p2) -> + Asmblockprops.bblock_simu ge fn p1 p2. +Proof. + unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. + generalize (H2 (trans_state (State rs m))); clear H2. + intro H2. + exploit (bisimu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. + exploit (bisimu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. + destruct (exec_bblock ge fn p1 rs m); try congruence. + intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. + destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3. + destruct (exec_bblock ge fn p2 rs m); simpl in H3. + * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. + cutrewrite (rs0=rs1). + - cutrewrite (m0=m1); auto. congruence. + - apply functional_extensionality. intros r. + generalize (H0 r). intros Hr. congruence. + * discriminate. +Qed. + +(** Used for debug traces *) + +Definition gpreg_name (gpr: gpreg) := + match gpr with + | GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4") + | GPR5 => Str ("GPR5") | GPR6 => Str ("GPR6") | GPR7 => Str ("GPR7") | GPR8 => Str ("GPR8") | GPR9 => Str ("GPR9") + | GPR10 => Str ("GPR10") | GPR11 => Str ("GPR11") | GPR12 => Str ("GPR12") | GPR13 => Str ("GPR13") | GPR14 => Str ("GPR14") + | GPR15 => Str ("GPR15") | GPR16 => Str ("GPR16") | GPR17 => Str ("GPR17") | GPR18 => Str ("GPR18") | GPR19 => Str ("GPR19") + | GPR20 => Str ("GPR20") | GPR21 => Str ("GPR21") | GPR22 => Str ("GPR22") | GPR23 => Str ("GPR23") | GPR24 => Str ("GPR24") + | GPR25 => Str ("GPR25") | GPR26 => Str ("GPR26") | GPR27 => Str ("GPR27") | GPR28 => Str ("GPR28") | GPR29 => Str ("GPR29") + | GPR30 => Str ("GPR30") | GPR31 => Str ("GPR31") | GPR32 => Str ("GPR32") | GPR33 => Str ("GPR33") | GPR34 => Str ("GPR34") + | GPR35 => Str ("GPR35") | GPR36 => Str ("GPR36") | GPR37 => Str ("GPR37") | GPR38 => Str ("GPR38") | GPR39 => Str ("GPR39") + | GPR40 => Str ("GPR40") | GPR41 => Str ("GPR41") | GPR42 => Str ("GPR42") | GPR43 => Str ("GPR43") | GPR44 => Str ("GPR44") + | GPR45 => Str ("GPR45") | GPR46 => Str ("GPR46") | GPR47 => Str ("GPR47") | GPR48 => Str ("GPR48") | GPR49 => Str ("GPR49") + | GPR50 => Str ("GPR50") | GPR51 => Str ("GPR51") | GPR52 => Str ("GPR52") | GPR53 => Str ("GPR53") | GPR54 => Str ("GPR54") + | GPR55 => Str ("GPR55") | GPR56 => Str ("GPR56") | GPR57 => Str ("GPR57") | GPR58 => Str ("GPR58") | GPR59 => Str ("GPR59") + | GPR60 => Str ("GPR60") | GPR61 => Str ("GPR61") | GPR62 => Str ("GPR62") | GPR63 => Str ("GPR63") + end. + +Definition string_of_name (x: P.R.t): ?? pstring := + if (Pos.eqb x pmem) then + RET (Str "MEM") + else + match inv_ppos x with + | Some RA => RET (Str ("RA")) + | Some PC => RET (Str ("PC")) + | Some (IR gpr) => RET (gpreg_name gpr) + | _ => RET (Str ("UNDEFINED")) + end. + +Definition string_of_name_r (n: arith_name_r): pstring := + match n with + | Ploadsymbol _ _ => "Ploadsymbol" + end. + +Definition string_of_name_rr (n: arith_name_rr): pstring := + match n with + Pmv => "Pmv" + | Pnegw => "Pnegw" + | Pnegl => "Pnegl" + | Pcvtl2w => "Pcvtl2w" + | Psxwd => "Psxwd" + | Pzxwd => "Pzxwd" + | Pextfz _ _ => "Pextfz" + | Pextfs _ _ => "Pextfs" + | Pextfzl _ _ => "Pextfzl" + | Pextfsl _ _ => "Pextfsl" + | Pfabsd => "Pfabsd" + | Pfabsw => "Pfabsw" + | Pfnegd => "Pfnegd" + | Pfnegw => "Pfnegw" + | Pfinvw => "Pfinvw" + | Pfnarrowdw => "Pfnarrowdw" + | Pfwidenlwd => "Pfwidenlwd" + | Pfloatwrnsz => "Pfloatwrnsz" + | Pfloatuwrnsz => "Pfloatuwrnsz" + | Pfloatudrnsz => "Pfloatudrnsz" + | Pfloatdrnsz => "Pfloatdrnsz" + | Pfixedwrzz => "Pfixedwrzz" + | Pfixeduwrzz => "Pfixeduwrzz" + | Pfixeddrzz => "Pfixeddrzz" + | Pfixedudrzz => "Pfixedudrzz" + | Pfixeddrzz_i32 => "Pfixeddrzz_i32" + | Pfixedudrzz_i32 => "Pfixedudrzz_i32" + end. + +Definition string_of_name_ri32 (n: arith_name_ri32): pstring := + match n with + | Pmake => "Pmake" + end. + +Definition string_of_name_ri64 (n: arith_name_ri64): pstring := + match n with + | Pmakel => "Pmakel" + end. + +Definition string_of_name_rf32 (n: arith_name_rf32): pstring := + match n with + | Pmakefs => "Pmakefs" + end. + +Definition string_of_name_rf64 (n: arith_name_rf64): pstring := + match n with + | Pmakef => "Pmakef" + end. + +Definition string_of_name_rrr (n: arith_name_rrr): pstring := + match n with + | Pcompw _ => "Pcompw" + | Pcompl _ => "Pcompl" + | Pfcompw _ => "Pfcompw" + | Pfcompl _ => "Pfcompl" + | Paddw => "Paddw" + | Paddxw _ => "Paddxw" + | Psubw => "Psubw" + | Prevsubxw _ => "Prevsubxw" + | Pmulw => "Pmulw" + | Pandw => "Pandw" + | Pnandw => "Pnandw" + | Porw => "Porw" + | Pnorw => "Pnorw" + | Pxorw => "Pxorw" + | Pnxorw => "Pnxorw" + | Pandnw => "Pandnw" + | Pornw => "Pornw" + | Psraw => "Psraw" + | Psrlw => "Psrlw" + | Psrxw => "Psrxw" + | Psllw => "Psllw" + | Paddl => "Paddl" + | Paddxl _ => "Paddxl" + | Psubl => "Psubl" + | Prevsubxl _ => "Prevsubxl" + | Pandl => "Pandl" + | Pnandl => "Pnandl" + | Porl => "Porl" + | Pnorl => "Pnorl" + | Pxorl => "Pxorl" + | Pnxorl => "Pnxorl" + | Pandnl => "Pandnl" + | Pornl => "Pornl" + | Pmull => "Pmull" + | Pslll => "Pslll" + | Psrll => "Psrll" + | Psrxl => "Psrxl" + | Psral => "Psral" + | Pfaddd => "Pfaddd" + | Pfaddw => "Pfaddw" + | Pfsbfd => "Pfsbfd" + | Pfsbfw => "Pfsbfw" + | Pfmuld => "Pfmuld" + | Pfmulw => "Pfmulw" + | Pfmind => "Pfmind" + | Pfminw => "Pfminw" + | Pfmaxd => "Pfmaxd" + | Pfmaxw => "Pfmaxw" + end. + +Definition string_of_name_rri32 (n: arith_name_rri32): pstring := + match n with + Pcompiw _ => "Pcompiw" + | Paddiw => "Paddiw" + | Paddxiw _ => "Paddxiw" + | Prevsubiw => "Prevsubiw" + | Prevsubxiw _ => "Prevsubxiw" + | Pmuliw => "Pmuliw" + | Pandiw => "Pandiw" + | Pnandiw => "Pnandiw" + | Poriw => "Poriw" + | Pnoriw => "Pnoriw" + | Pxoriw => "Pxoriw" + | Pnxoriw => "Pnxoriw" + | Pandniw => "Pandniw" + | Porniw => "Porniw" + | Psraiw => "Psraiw" + | Psrliw => "Psrliw" + | Psrxiw => "Psrxiw" + | Pslliw => "Pslliw" + | Proriw => "Proriw" + | Psllil => "Psllil" + | Psrlil => "Psrlil" + | Psrail => "Psrail" + | Psrxil => "Psrxil" + end. + +Definition string_of_name_rri64 (n: arith_name_rri64): pstring := + match n with + Pcompil _ => "Pcompil" + | Paddil => "Paddil" + | Prevsubil => "Prevsubil" + | Paddxil _ => "Paddxil" + | Prevsubxil _ => "Prevsubxil" + | Pmulil => "Pmulil" + | Pandil => "Pandil" + | Pnandil => "Pnandil" + | Poril => "Poril" + | Pnoril => "Pnoril" + | Pxoril => "Pxoril" + | Pnxoril => "Pnxoril" + | Pandnil => "Pandnil" + | Pornil => "Pornil" + end. + +Definition string_of_name_arrr (n: arith_name_arrr): pstring := + match n with + | Pmaddw => "Pmaddw" + | Pmaddl => "Pmaddl" + | Pmsubw => "Pmsubw" + | Pmsubl => "Pmsubl" + | Pcmove _ => "Pcmove" + | Pcmoveu _ => "Pcmoveu" + | Pfmaddfw => "Pfmaddfw" + | Pfmaddfl => "Pfmaddfl" + | Pfmsubfw => "Pfmsubfw" + | Pfmsubfl => "Pfmsubfl" + end. + +Definition string_of_name_arr (n: arith_name_arr): pstring := + match n with + | Pinsf _ _ => "Pinsf" + | Pinsfl _ _ => "Pinsfl" + end. + +Definition string_of_name_arri32 (n: arith_name_arri32): pstring := + match n with + | Pmaddiw => "Pmaddw" + | Pcmoveiw _ => "Pcmoveiw" + | Pcmoveuiw _ => "Pcmoveuiw" + end. + +Definition string_of_name_arri64 (n: arith_name_arri64): pstring := + match n with + | Pmaddil => "Pmaddl" + | Pcmoveil _ => "Pcmoveil" + | Pcmoveuil _ => "Pcmoveuil" + end. + +Definition string_of_arith (op: arith_op): pstring := + match op with + | OArithR n => string_of_name_r n + | OArithRR n => string_of_name_rr n + | OArithRI32 n _ => string_of_name_ri32 n + | OArithRI64 n _ => string_of_name_ri64 n + | OArithRF32 n _ => string_of_name_rf32 n + | OArithRF64 n _ => string_of_name_rf64 n + | OArithRRR n => string_of_name_rrr n + | OArithRRI32 n _ => string_of_name_rri32 n + | OArithRRI64 n _ => string_of_name_rri64 n + | OArithARRR n => string_of_name_arrr n + | OArithARR n => string_of_name_arr n + | OArithARRI32 n _ => string_of_name_arri32 n + | OArithARRI64 n _ => string_of_name_arri64 n + end. + +Definition string_of_load_name (n: load_name) : pstring := + match n with + Plb => "Plb" + | Plbu => "Plbu" + | Plh => "Plh" + | Plhu => "Plhu" + | Plw => "Plw" + | Plw_a => "Plw_a" + | Pld => "Pld" + | Pld_a => "Pld_a" + | Pfls => "Pfls" + | Pfld => "Pfld" + end. + +Definition string_of_load (op: load_op): pstring := + match op with + | OLoadRRO n _ _ => string_of_load_name n + | OLoadRRR n _ => string_of_load_name n + | OLoadRRRXS n _ => string_of_load_name n + end. + +Definition string_of_store_name (n: store_name) : pstring := + match n with + Psb => "Psb" + | Psh => "Psh" + | Psw => "Psw" + | Psw_a => "Psw_a" + | Psd => "Psd" + | Psd_a => "Psd_a" + | Pfss => "Pfss" + | Pfsd => "Pfsd" + end. + +Definition string_of_store (op: store_op) : pstring := + match op with + | OStoreRRO n _ => string_of_store_name n + | OStoreRRR n => string_of_store_name n + | OStoreRRRXS n => string_of_store_name n + end. + +Definition string_of_control (op: control_op) : pstring := + match op with + | Oj_l _ => "Oj_l" + | Ocb _ _ => "Ocb" + | Ocbu _ _ => "Ocbu" + | Odiv => "Odiv" + | Odivu => "Odivu" + | Ojumptable _ => "Ojumptable" + | OError => "OError" + | OIncremPC _ => "OIncremPC" + end. + +Definition string_of_op (op: P.op): ?? pstring := + match op with + | Arith op => RET (string_of_arith op) + | Load op => RET (string_of_load op) + | Store op => RET (string_of_store op) + | Control op => RET (string_of_control op) + | Allocframe _ _ => RET (Str "Allocframe") + | Allocframe2 _ _ => RET (Str "Allocframe2") + | Freeframe _ _ => RET (Str "Freeframe") + | Freeframe2 _ _ => RET (Str "Freeframe2") + | Constant _ => RET (Str "Constant") + | Fail => RET (Str "Fail") + end. + +End SECT_BBLOCK_EQUIV. + +(** REWRITE RULES *) + +Definition is_constant (o: op): bool := + match o with + | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true + | _ => false + end. + +Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None. +Proof. + destruct o; simpl in * |- *; try congruence. + destruct ao; simpl in * |- *; try congruence; + destruct n; simpl in * |- *; try congruence; + unfold arith_eval; destruct ge; simpl in * |- *; try congruence. +Qed. + +Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t). + +Local Hint Resolve is_constant_correct: wlp. + +Lemma main_reduce_correct t: + WHEN main_reduce t ~> pt THEN Terms.match_pt t pt. +Proof. + wlp_simplify. +Qed. + +Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}. + +Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := + if verb then + IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2) + else + IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). + +Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. + +Theorem bblock_simu_test_correct verb p1 p2 : + WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2. +Proof. + wlp_simplify. +Qed. +Hint Resolve bblock_simu_test_correct: wlp. + +(* Coerce bblock_simu_test into a pure function (this is a little unsafe like all oracles in CompCert). *) + +Import UnsafeImpure. + +Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := + match unsafe_coerce (bblock_simu_test verb p1 p2) with + | Some b => b + | None => false + end. + +Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. +Proof. + unfold pure_bblock_simu_test. + destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. + intros; subst. eapply bblock_simu_test_correct; eauto. + apply unsafe_coerce_not_really_correct; eauto. +Qed. + +Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. + +Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. +Proof. + eapply (pure_bblock_simu_test_correct true). +Qed. diff --git a/kvx/Asmblockgen.v b/kvx/Asmblockgen.v new file mode 100644 index 00000000..7167cebe --- /dev/null +++ b/kvx/Asmblockgen.v @@ -0,0 +1,1217 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Translation from Machblock to KVX assembly language (Asmblock) + Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *) + +Require Archi. +Require Import Coqlib Errors. +Require Import AST Integers Floats Memdata. +Require Import Op Locations Machblock Asmblock. +Require ExtValues. +Require Import Chunks. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +Import PArithCoercions. + +(** The code generation functions take advantage of several + characteristics of the [Mach] code generated by earlier passes of the + compiler, mostly that argument and result registers are of the correct + types. These properties are true by construction, but it's easier to + recheck them during code generation and fail if they do not hold. *) + +(** Extracting integer or float registers. *) + +Definition ireg_of (r: mreg) : res ireg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. + +Definition freg_of (r: mreg) : res freg := + match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. + +Inductive immed32 : Type := + | Imm32_single (imm: int). + +Definition make_immed32 (val: int) := Imm32_single val. + +Inductive immed64 : Type := + | Imm64_single (imm: int64) +. + +Definition make_immed64 (val: int64) := Imm64_single val. + +Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). +Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). +Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). +Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity). +Notation "a @@ b" := (app a b) (at level 49, right associativity). + +Definition loadimm32 (r: ireg) (n: int) := + match make_immed32 n with + | Imm32_single imm => Pmake r imm + end. + +Definition opimm32 (op: arith_name_rrr) + (opimm: arith_name_rri32) + (rd rs: ireg) (n: int) := + match make_immed32 n with + | Imm32_single imm => opimm rd rs imm + end. + +Definition addimm32 := opimm32 Paddw Paddiw. +Definition mulimm32 := opimm32 Pmulw Pmuliw. +Definition andimm32 := opimm32 Pandw Pandiw. +Definition nandimm32 := opimm32 Pnandw Pnandiw. +Definition orimm32 := opimm32 Porw Poriw. +Definition norimm32 := opimm32 Pnorw Pnoriw. +Definition xorimm32 := opimm32 Pxorw Pxoriw. +Definition nxorimm32 := opimm32 Pnxorw Pnxoriw. + +Definition loadimm64 (r: ireg) (n: int64) := + match make_immed64 n with + | Imm64_single imm => Pmakel r imm + end. + +Definition opimm64 (op: arith_name_rrr) + (opimm: arith_name_rri64) + (rd rs: ireg) (n: int64) := + match make_immed64 n with + | Imm64_single imm => opimm rd rs imm +end. + +Definition addimm64 := opimm64 Paddl Paddil. +Definition mulimm64 := opimm64 Pmull Pmulil. +Definition orimm64 := opimm64 Porl Poril. +Definition andimm64 := opimm64 Pandl Pandil. +Definition xorimm64 := opimm64 Pxorl Pxoril. +Definition norimm64 := opimm64 Pnorl Pnoril. +Definition nandimm64 := opimm64 Pnandl Pnandil. +Definition nxorimm64 := opimm64 Pnxorl Pnxoril. + +Definition addptrofs (rd rs: ireg) (n: ptrofs) := + if Ptrofs.eq_dec n Ptrofs.zero then + Pmv rd rs + else + addimm64 rd rs (Ptrofs.to_int64 n). + +(** Translation of conditional branches. *) + +Definition transl_comp + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. + +Definition transl_compi + (c: comparison) (s: signedness) (r: ireg) (imm: int) (lbl: label) (k: code) : list instruction := + Pcompiw (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. + +Definition transl_compl + (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := + Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. + +Definition transl_compil + (c: comparison) (s: signedness) (r: ireg) (imm: int64) (lbl: label) (k: code) : list instruction := + Pcompil (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. + +Definition select_comp (n: int) (c: comparison) : option comparison := + if Int.eq n Int.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compuimm + (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + if Int.eq n Int.zero then + match c with + | Ceq => Pcbu BTweqz r1 lbl ::g k + | Cne => Pcbu BTwnez r1 lbl ::g k + | _ => transl_compi c Unsigned r1 n lbl k + end + else + transl_compi c Unsigned r1 n lbl k + . + +Definition select_compl (n: int64) (c: comparison) : option comparison := + if Int64.eq n Int64.zero then + match c with + | Ceq => Some Ceq + | Cne => Some Cne + | _ => None + end + else + None + . + +Definition transl_opt_compluimm + (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := + if Int64.eq n Int64.zero then + match c with + | Ceq => Pcbu BTdeqz r1 lbl ::g k + | Cne => Pcbu BTdnez r1 lbl ::g k + | _ => transl_compil c Unsigned r1 n lbl k + end + else + transl_compil c Unsigned r1 n lbl k + . + +Definition transl_comp_float32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_notfloat32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_float64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_comp_notfloat64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k + | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k + end. + +Definition transl_cbranch + (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := + match cond, args with + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compuimm n c r1 lbl k) + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Signed r1 r2 lbl k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp c Unsigned r1 r2 lbl k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int.eq n Int.zero then + Pcb (btest_for_cmpswz c) r1 lbl ::g k + else + transl_compi c Signed r1 n lbl k + ) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_opt_compluimm n c r1 lbl k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Signed r1 r2 lbl k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_compl c Unsigned r1 r2 lbl k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (if Int64.eq n Int64.zero then + Pcb (btest_for_cmpsdz c) r1 lbl ::g k + else + transl_compil c Signed r1 n lbl k + ) + | Ccompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_float64 c r1 r2 lbl k) + | Cnotcompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_notfloat64 c r1 r2 lbl k) + | Ccompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_float32 c r1 r2 lbl k) + | Cnotcompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_comp_notfloat32 c r1 r2 lbl k) + | _, _ => + Error(msg "Asmgenblock.transl_cbranch") + end. + +(** Translation of a condition operator. The generated code sets the + [rd] target register to 0 or 1 depending on the truth value of the + condition. *) + +Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. + +Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. + +Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := + Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := + Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + +Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := + Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. + +Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := + Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. + + +Definition transl_cond_float32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompw ft rd r1 r2 ::i k + | Reversed ft => Pfcompw ft rd r2 r1 ::i k + end. + +Definition transl_cond_notfloat32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompw ft rd r1 r2 ::i k + | Reversed ft => Pfcompw ft rd r2 r1 ::i k + end. + +Definition transl_cond_float64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match ftest_for_cmp cmp with + | Normal ft => Pfcompl ft rd r1 r2 ::i k + | Reversed ft => Pfcompl ft rd r2 r1 ::i k + end. + +Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := + match notftest_for_cmp cmp with + | Normal ft => Pfcompl ft rd r1 r2 ::i k + | Reversed ft => Pfcompl ft rd r2 r1 ::i k + end. + + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpuwz (c: comparison) := + match c with + | Cne => OK BTwnez + | Ceq => OK BTweqz + | Clt => Error (msg "btest_for_compuwz: Clt") + | Cge => Error (msg "btest_for_compuwz: Cge") + | Cle => OK BTweqz + | Cgt => OK BTwnez + end. + +(* CoMPare Unsigned Words to Zero *) +Definition btest_for_cmpudz (c: comparison) := + match c with + | Cne => OK BTdnez + | Ceq => OK BTdeqz + | Clt => Error (msg "btest_for_compudz: Clt") + | Cge => Error (msg "btest_for_compudz: Cge") + | Cle => OK BTdeqz + | Cgt => OK BTdnez + end. + +Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : + res basic := + if ireg_eq rd rs + then OK Pnop + else + (match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmove (btest_for_cmpswz cmp) rd rc rs)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + | Ccompl0 cmp => + OK (PArith (Pcmove (btest_for_cmpsdz cmp) rd rc rs)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveu bt rd rc rs)) + end). + +Definition conditional_move_imm32 (cond0 : condition0) (rc rd : ireg) (imm : int) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveiw (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuiw bt rd rc imm)) + end. + +Definition conditional_move_imm64 (cond0 : condition0) (rc rd : ireg) (imm : int64) : res basic := + match cond0 with + | Ccomp0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpswz cmp) rd rc imm)) + | Ccompu0 cmp => + do bt <- btest_for_cmpuwz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + | Ccompl0 cmp => + OK (PArith (Pcmoveil (btest_for_cmpsdz cmp) rd rc imm)) + | Ccomplu0 cmp => + do bt <- btest_for_cmpudz cmp; + OK (PArith (Pcmoveuil bt rd rc imm)) + end. + +Definition transl_cond_op + (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32s c rd r1 r2 k) + | Ccompu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int32u c rd r1 r2 k) + | Ccompimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32s c rd r1 n k) + | Ccompuimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int32u c rd r1 n k) + | Ccompl c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64s c rd r1 r2 k) + | Ccomplu c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_int64u c rd r1 r2 k) + | Ccomplimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64s c rd r1 n k) + | Ccompluimm c n, a1 :: nil => + do r1 <- ireg_of a1; + OK (transl_condimm_int64u c rd r1 n k) + | Ccompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_float32 c rd r1 r2 k) + | Cnotcompfs c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_notfloat32 c rd r1 r2 k) + | Ccompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_float64 c rd r1 r2 k) + | Cnotcompf c, a1 :: a2 :: nil => + do r1 <- ireg_of a1; do r2 <- ireg_of a2; + OK (transl_cond_notfloat64 c rd r1 r2 k) + | _, _ => + Error(msg "Asmblockgen.transl_cond_op") +end. + +(** 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: bcode) := + match op, args with + | Omove, a1 :: nil => + match preg_of res, preg_of a1 with + | IR r, IR a => OK (Pmv r a ::i k) + | _ , _ => Error(msg "Asmgenblock.transl_op: Omove") + end + | Ointconst n, nil => + do rd <- ireg_of res; + OK (loadimm32 rd n ::i k) + | Olongconst n, nil => + do rd <- ireg_of res; + OK (loadimm64 rd n ::i k) + | Ofloatconst f, nil => + do rd <- freg_of res; + OK (Pmakef rd f ::i k) + | Osingleconst f, nil => + do rd <- freg_of res; + OK (Pmakefs rd f ::i k) + | Oaddrsymbol s ofs, nil => + do rd <- ireg_of res; + OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) + then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k + else Ploadsymbol s ofs rd ::i k) + | Oaddrstack n, nil => + do rd <- ireg_of res; + OK (addptrofs rd SP n ::i k) + + | Ocast8signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) + | Ocast16signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k) + | Oadd, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddw rd rs1 rs2 ::i k) + | Oaddimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm32 rd rs n ::i k) + | Oaddx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxw shift rd rs1 rs2 ::i k) + | Oaddximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxiw shift rd rs n ::i k) + | Oaddxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddxl shift rd rs1 rs2 ::i k) + | Oaddxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Paddxil shift rd rs n ::i k) + | Oneg, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pnegw rd rs ::i k) + | Osub, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psubw rd rs1 rs2 ::i k) + | Orevsubimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubiw rd rs n ::i k) + | Orevsubx shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxw shift rd rs1 rs2 ::i k) + | Orevsubximm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxiw shift rd rs n ::i k) + | Omul, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmulw rd rs1 rs2 ::i k) + | Omulimm n, a1 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; + OK (mulimm32 rd rs1 n ::i k) + | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") (* Normalement pas émis *) + | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (* Normalement pas émis *) + | Oand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandw rd rs1 rs2 ::i k) + | Oandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm32 rd rs n ::i k) + | Onand, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnandw rd rs1 rs2 ::i k) + | Onandimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nandimm32 rd rs n ::i k) + | Oor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porw rd rs1 rs2 ::i k) + | Onor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnorw rd rs1 rs2 ::i k) + | Oorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm32 rd rs n ::i k) + | Onorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (norimm32 rd rs n ::i k) + | Oxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorw rd rs1 rs2 ::i k) + | Oxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs n ::i k) + | Onxor, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnxorw rd rs1 rs2 ::i k) + | Onxorimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nxorimm32 rd rs n ::i k) + | Onot, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm32 rd rs Int.mone ::i k) + | Oandn, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandnw rd rs1 rs2 ::i k) + | Oandnimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pandniw rd rs n ::i k) + | Oorn, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pornw rd rs1 rs2 ::i k) + | Oornimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Porniw rd rs n ::i k) + | Oshl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psllw rd rs1 rs2 ::i k) + | Oshlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pslliw rd rs n ::i k) + | Oshr, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psraw rd rs1 rs2 ::i k) + | Oshrimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psraiw rd rs n ::i k) + | Oshru, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrlw rd rs1 rs2 ::i k) + | Oshruimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrliw rd rs n ::i k) + | Oshrximm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrxiw rd rs n ::i k) + | Ororimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Proriw rd rs n ::i k) + | Omadd, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmaddw r1 r2 r3 ::i k) + | Omaddimm n, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + OK (Pmaddiw r1 r2 n ::i k) + | Omsub, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubw r1 r2 r3 ::i k) + (* [Omakelong], [Ohighlong] should not occur *) + | Olowlong, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pcvtl2w rd rs ::i k) + | Ocast32signed, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psxwd rd rs ::i k) + | Ocast32unsigned, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pzxwd rd rs ::i k) +(* assertion (ireg_eq rd rs); + OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) *) + | Oaddl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Paddl rd rs1 rs2 ::i k) + | Oaddlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (addimm64 rd rs n ::i k) + | Onegl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pnegl rd rs ::i k) + | Osubl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psubl rd rs1 rs2 ::i k) + | Orevsubxl shift, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Prevsubxl shift rd rs1 rs2 ::i k) + | Orevsublimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubil rd rs n ::i k) + | Orevsubxlimm shift n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Prevsubxil shift rd rs n ::i k) + | Omull, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pmull rd rs1 rs2 ::i k) + | Omullimm n, a1 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; + OK (mulimm64 rd rs1 n ::i k) + | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") (* Normalement pas émis *) + | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") (* Normalement pas émis *) + | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") (* Géré par fonction externe *) + | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") (* Géré par fonction externe *) + | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") (* Géré par fonction externe *) + | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") (* Géré par fonction externe *) + | Onotl, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs Int64.mone ::i k) + | Oandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandl rd rs1 rs2 ::i k) + | Oandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (andimm64 rd rs n ::i k) + | Onandl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnandl rd rs1 rs2 ::i k) + | Onandlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nandimm64 rd rs n ::i k) + | Oorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Porl rd rs1 rs2 ::i k) + | Oorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (orimm64 rd rs n ::i k) + | Onorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnorl rd rs1 rs2 ::i k) + | Onorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (norimm64 rd rs n ::i k) + | Oxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pxorl rd rs1 rs2 ::i k) + | Oxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (xorimm64 rd rs n ::i k) + | Onxorl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pnxorl rd rs1 rs2 ::i k) + | Onxorlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (nxorimm64 rd rs n ::i k) + | Oandnl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pandnl rd rs1 rs2 ::i k) + | Oandnlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pandnil rd rs n ::i k) + | Oornl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pornl rd rs1 rs2 ::i k) + | Oornlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pornil rd rs n ::i k) + | Oshll, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Pslll rd rs1 rs2 ::i k) + | Oshllimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psllil rd rs n ::i k) + | Oshrl, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psral rd rs1 rs2 ::i k) + | Oshrlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrail rd rs n ::i k) + | Oshrlu, a1 :: a2 :: nil => + do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; + OK (Psrll rd rs1 rs2 ::i k) + | Oshrluimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrlil rd rs n ::i k) + | Oshrxlimm n, a1 :: nil => + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Psrxil rd rs n ::i k) + | Omaddl, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmaddl r1 r2 r3 ::i k) + | Omaddlimm n, a1 :: a2 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + OK (Pmaddil r1 r2 n ::i k) + | Omsubl, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do r1 <- ireg_of a1; + do r2 <- ireg_of a2; + do r3 <- ireg_of a3; + OK (Pmsubl r1 r2 r3 ::i k) + | Oabsf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsd rd rs ::i k) + | Oabsfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfabsw rd rs ::i k) + | Oaddf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddd rd rs1 rs2 ::i k) + | Oaddfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfaddw rd rs1 rs2 ::i k) + | Osubf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsbfd rd rs1 rs2 ::i k) + | Osubfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfsbfw rd rs1 rs2 ::i k) + | Omulf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmuld rd rs1 rs2 ::i k) + | Omulfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmulw rd rs1 rs2 ::i k) + | Ominf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmind rd rs1 rs2 ::i k) + | Ominfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfminw rd rs1 rs2 ::i k) + | Omaxf, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxd rd rs1 rs2 ::i k) + | Omaxfs, a1 :: a2 :: nil => + do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; + OK (Pfmaxw rd rs1 rs2 ::i k) + | Onegf, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegd rd rs ::i k) + | Onegfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnegw rd rs ::i k) + | Oinvfs, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfinvw rd rs ::i k) + + | Ofmaddf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfl rs1 rs2 rs3 ::i k) + | Ofmaddfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmaddfw rs1 rs2 rs3 ::i k) + | Ofmsubf, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfl rs1 rs2 rs3 ::i k) + | Ofmsubfs, a1 :: a2 :: a3 :: nil => + assertion (mreg_eq a1 res); + do rs1 <- freg_of a1; + do rs2 <- freg_of a2; + do rs3 <- freg_of a3; + OK (Pfmsubfw rs1 rs2 rs3 ::i k) + + | Osingleofint, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatwrnsz rd rs ::i k) + | Osingleofintu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatuwrnsz rd rs ::i k) + | Ofloatoflong, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatdrnsz rd rs ::i k) + | Ofloatoflongu, a1 :: nil => + do rd <- freg_of res; do rs <- ireg_of a1; + OK (Pfloatudrnsz rd rs ::i k) + | Ointofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedwrzz rd rs ::i k) + | Ointuofsingle, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeduwrzz rd rs ::i k) + | Olongoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeddrzz rd rs ::i k) + | Ointoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixeddrzz_i32 rd rs ::i k) + | Ointuoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedudrzz_i32 rd rs ::i k) + | Olonguoffloat, a1 :: nil => + do rd <- ireg_of res; do rs <- freg_of a1; + OK (Pfixedudrzz rd rs ::i k) + + | Ofloatofsingle, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfwidenlwd rd rs ::i k) + | Osingleoffloat, a1 :: nil => + do rd <- freg_of res; do rs <- freg_of a1; + OK (Pfnarrowdw rd rs ::i k) + + + | Odivf , _ => Error (msg "Asmblockgen.transl_op: Odivf") + | Odivfs, _ => Error (msg "Asmblockgen.transl_op: Odivfs") + + (* We use the Splitlong instead for these four conversions *) + | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") + | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") + | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") + | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") + + + | Ocmp cmp, _ => + do rd <- ireg_of res; + transl_cond_op cmp rd args k + + + | Oextfz stop start, a1 :: nil => + assertion (ExtValues.is_bitfield stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfz stop start rd rs ::i k) + + | Oextfs stop start, a1 :: nil => + assertion (ExtValues.is_bitfield stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfs stop start rd rs ::i k) + + | Oextfzl stop start, a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfzl stop start rd rs ::i k) + + | Oextfsl stop start, a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pextfsl stop start rd rs ::i k) + + | Oinsf stop start, a0 :: a1 :: nil => + assertion (ExtValues.is_bitfield stop start); + assertion (mreg_eq a0 res); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pinsf stop start rd rs ::i k) + + | Oinsfl stop start, a0 :: a1 :: nil => + assertion (ExtValues.is_bitfieldl stop start); + assertion (mreg_eq a0 res); + do rd <- ireg_of res; do rs <- ireg_of a1; + OK (Pinsfl stop start rd rs ::i k) + + | Osel cond0 ty, aT :: aF :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rF <- ireg_of aF; + do rC <- ireg_of aC; + do op <- conditional_move (negate_condition0 cond0) rC rT rF; + OK (op ::i k) + + | Oselimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm32 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) + + + | Osellimm cond0 imm, aT :: aC :: nil => + assertion (mreg_eq aT res); + do rT <- ireg_of aT; + do rC <- ireg_of aC; + do op <- conditional_move_imm64 (negate_condition0 cond0) rC rT imm; + OK (op ::i k) + + | _, _ => + Error(msg "Asmgenblock.transl_op") + end. + +(** Accessing data in the stack frame. *) + +Definition indexed_memory_access + (mk_instr: ireg -> offset -> basic) + (base: ireg) (ofs: ptrofs) := + match make_immed64 (Ptrofs.to_int64 ofs) with + | Imm64_single imm => + mk_instr base (Ptrofs.of_int64 imm) +end. + +Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := + match ty, preg_of dst with + | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k) + | _, _ => Error (msg "Asmblockgen.loadind") + end. + +Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := + match ty, preg_of src with + | Tint, IR rd => OK (indexed_memory_access (PStoreRRO Psw rd) base ofs ::i k) + | Tlong, IR rd => OK (indexed_memory_access (PStoreRRO Psd rd) base ofs ::i k) + | Tsingle, IR rd => OK (indexed_memory_access (PStoreRRO Pfss rd) base ofs ::i k) + | Tfloat, IR rd => OK (indexed_memory_access (PStoreRRO Pfsd rd) base ofs ::i k) + | Tany32, IR rd => OK (indexed_memory_access (PStoreRRO Psw_a rd) base ofs ::i k) + | Tany64, IR rd => OK (indexed_memory_access (PStoreRRO Psd_a rd) base ofs ::i k) + | _, _ => Error (msg "Asmblockgen.storeind") + end. + +Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := + indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs. + +Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := + indexed_memory_access (PStoreRRO Psd src) base ofs. + +(** Translation of memory accesses: loads, and stores. *) + +Definition transl_memory_access2 + (mk_instr: ireg -> ireg -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := + match addr, args with + | Aindexed2, a1 :: a2 :: nil => + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (mk_instr rs1 rs2 ::i k) + | _, _ => Error (msg "Asmblockgen.transl_memory_access2") + end. + +Definition transl_memory_access2XS + (chunk: memory_chunk) + (mk_instr: ireg -> ireg -> basic) + scale (args: list mreg) (k: bcode) : res bcode := + match args with + | (a1 :: a2 :: nil) => + assertion (Z.eqb (zscale_of_chunk chunk) scale); + do rs1 <- ireg_of a1; + do rs2 <- ireg_of a2; + OK (mk_instr rs1 rs2 ::i k) + | _ => Error (msg "Asmblockgen.transl_memory_access2XS") + end. + +Definition transl_memory_access + (mk_instr: ireg -> offset -> basic) + (addr: addressing) (args: list mreg) (k: bcode) : res bcode := + match addr, args with + | Aindexed ofs, a1 :: nil => + do rs <- ireg_of a1; + OK (indexed_memory_access mk_instr rs ofs ::i k) + | Aglobal id ofs, nil => + OK (Ploadsymbol id ofs RTMP ::i (mk_instr RTMP Ptrofs.zero ::i k)) + | Ainstack ofs, nil => + OK (indexed_memory_access mk_instr SP ofs ::i k) + | _, _ => + Error(msg "Asmblockgen.transl_memory_access") + end. + +Definition chunk2load (chunk: memory_chunk) := + match chunk with + | Mint8signed => Plb + | Mint8unsigned => Plbu + | Mint16signed => Plh + | Mint16unsigned => Plhu + | Mint32 => Plw + | Mint64 => Pld + | Mfloat32 => Pfls + | Mfloat64 => Pfld + | Many32 => Plw_a + | Many64 => Pld_a + end. + +Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + do r <- ireg_of dst; + transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k. + +Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + do r <- ireg_of dst; + transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k. + +Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + do r <- ireg_of dst; + transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k. + +Definition transl_load (trap : trapping_mode) + (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (dst: mreg) (k: bcode) : res bcode := + match addr with + | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k + | Aindexed2 => transl_load_rrr trap chunk addr args dst k + | _ => transl_load_rro trap chunk addr args dst k + end. + +Definition chunk2store (chunk: memory_chunk) := + match chunk with + | Mint8signed | Mint8unsigned => Psb + | Mint16signed | Mint16unsigned => Psh + | Mint32 => Psw + | Mint64 => Psd + | Mfloat32 => Pfss + | Mfloat64 => Pfsd + | Many32 => Psw_a + | Many64 => Psd_a + end. + +Definition transl_store_rro (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + do r <- ireg_of src; + transl_memory_access (PStoreRRO (chunk2store chunk) r) addr args k. + +Definition transl_store_rrr (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + do r <- ireg_of src; + transl_memory_access2 (PStoreRRR (chunk2store chunk) r) addr args k. + +Definition transl_store_rrrxs (chunk: memory_chunk) (scale: Z) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + do r <- ireg_of src; + transl_memory_access2XS chunk (PStoreRRRXS (chunk2store chunk) r) scale args k. + +Definition transl_store (chunk: memory_chunk) (addr: addressing) + (args: list mreg) (src: mreg) (k: bcode) : res bcode := + match addr with + | Aindexed2 => transl_store_rrr chunk addr args src k + | Aindexed2XS scale => transl_store_rrrxs chunk scale args src k + | _ => transl_store_rro chunk addr args src k + end. + +(** Function epilogue *) + +Definition make_epilogue (f: Machblock.function) (k: code) := + (loadind_ptr SP f.(fn_retaddr_ofs) GPRA) + ::g Pset RA GPRA ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. + +(** Translation of a Machblock instruction. *) + +Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) + (ep: bool) (k: bcode) := + match i with + | MBgetstack ofs ty dst => + loadind SP ofs ty dst k + | MBsetstack src ofs ty => + storeind src SP ofs ty k + | MBgetparam ofs ty dst => + (* load via the frame pointer if it is valid *) + do c <- loadind FP ofs ty dst k; + OK (if ep then c + else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) + | MBop op args res => + transl_op op args res k + | MBload trap chunk addr args dst => + transl_load trap chunk addr args dst k + | MBstore chunk addr args src => + transl_store chunk addr args src k + end. + +Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst) + : res code := + match oi with + | None => OK nil + | Some i => + match i with + | MBcall sig (inl r) => + do r1 <- ireg_of r; OK ((Picall r1) ::g nil) + | MBcall sig (inr symb) => + OK ((Pcall symb) ::g nil) + | MBtailcall sig (inr symb) => + OK (make_epilogue f ((Pgoto symb) ::g nil)) + | MBtailcall sig (inl r) => + do r1 <- ireg_of r; OK (make_epilogue f ((Pigoto r1) ::g nil)) + | MBbuiltin ef args res => + OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) + | MBgoto lbl => + OK (Pj_l lbl ::g nil) + | MBcond cond args lbl => + transl_cbranch cond args lbl nil + | MBreturn => + OK (make_epilogue f (Pret ::g nil)) + | MBjumptable arg tbl => + do r <- ireg_of arg; + OK (Pjumptable r tbl ::g nil) + end + end. + +(** Translation of a code sequence *) + +Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := + match i with + | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP) + | MBsetstack src ofs ty => before + | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) + | MBop op args res => before && negb (mreg_eq res MFP) + | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) + | MBstore chunk addr args res => before + end. + +(** This is the naive definition, which is not tail-recursive unlike the other backends *) + +Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + match il with + | nil => OK nil + | i1 :: il' => + do k <- transl_basic_code f il' (fp_is_parent it1p i1); + transl_instr_basic f i1 it1p k + end. + +(* (** This is an equivalent definition in continuation-passing style + that runs in constant stack space. *) + +Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) + (it1p: bool) (k: bcode -> res bcode) := + match il with + | nil => k nil + | i1 :: il' => + transl_basic_rec f il' (fp_is_parent it1p i1) + (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2) + end. + +Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := + transl_basic_rec f il it1p (fun c => OK c). *) + +(** Translation of a whole function. Note that we must check + that the generated code contains less than [2^64] instructions, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +(* gen_bblocks can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) +Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := + match (extract_ctl ctl) with + | None => + match c with + | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil + | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil + end + | Some (PExpand (Pbuiltin ef args res)) => + match c with + | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + | _ => {| header := hd; body := c; exit := None |} + :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil + end + | Some ex => {| header := hd; body := (c ++ extract_basic ctl); exit := Some ex |} :: nil + end +. +Next Obligation. + apply wf_bblock_refl. constructor. + left. auto. + discriminate. +Qed. Next Obligation. + apply wf_bblock_refl. constructor. + right. discriminate. + unfold builtin_alone. intros. pose (H ef args res). rewrite H0 in n. contradiction. +Qed. + +Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := + do c <- transl_basic_code f fb.(Machblock.body) ep; + do ctl <- transl_instr_control f fb.(Machblock.exit); + OK (gen_bblocks fb.(Machblock.header) c ctl) +. + +Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := + match lmb with + | nil => OK nil + | mb :: lmb => + do lb <- transl_block f mb (if Machblock.header mb then ep else false); + do lb' <- transl_blocks f lmb false; + OK (lb @@ lb') + end +. + +Program Definition make_prologue (f: Machblock.function) lb := + ({| header := nil; body := Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i + Pget GPRA RA ::i + storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::i nil; + exit := None |} :: lb). + +Definition transl_function (f: Machblock.function) := + do lb <- transl_blocks f f.(Machblock.fn_code) true; + OK (mkfunction f.(Machblock.fn_sig) + (make_prologue f lb)). + +Definition transf_function (f: Machblock.function) : res Asmvliw.function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: Machblock.fundef) : res Asmvliw.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Machblock.program) : res Asmvliw.program := + transform_partial_program transf_fundef p. diff --git a/kvx/Asmblockgenproof.v b/kvx/Asmblockgenproof.v new file mode 100644 index 00000000..5cb498bc --- /dev/null +++ b/kvx/Asmblockgenproof.v @@ -0,0 +1,1807 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Correctness proof for RISC-V generation: main proof. *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. +Require Import Axioms. + +Module MB := Machblock. +Module AB := Asmvliw. + +Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Section PRESERVATION. + +Variable prog: Machblock.program. +Variable tprog: Asmvliw.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. +Qed. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) + +Lemma gen_bblocks_label: + forall hd bdy ex tbb tc, + gen_bblocks hd bdy ex = tbb::tc -> + header tbb = hd. +Proof. + intros until tc. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Lemma gen_bblocks_label2: + forall hd bdy ex tbb1 tbb2, + gen_bblocks hd bdy ex = tbb1::tbb2::nil -> + header tbb2 = nil. +Proof. + intros until tbb2. intros GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. + all: inv GENB; simpl; auto. +Qed. + +Remark in_dec_transl: + forall lbl hd, + (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). +Proof. + intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. +Qed. + +Lemma transl_is_label: + forall lbl bb tbb f ep tc, + transl_block f bb ep = OK (tbb::tc) -> + is_label lbl tbb = MB.is_label lbl bb. +Proof. + intros until tc. intros TLB. + destruct tbb as [thd tbdy tex]; simpl in *. + monadInv TLB. + unfold is_label. simpl. + apply gen_bblocks_label in H0. simpl in H0. subst. + rewrite in_dec_transl. auto. +Qed. + +Lemma transl_is_label_false2: + forall lbl bb f ep tbb1 tbb2, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb2 = false. +Proof. + intros until tbb2. intros TLB. + destruct tbb2 as [thd tbdy tex]; simpl in *. + monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. + apply is_label_correct_false. simpl. auto. +Qed. + +Lemma transl_is_label2: + forall f bb ep tbb1 tbb2 lbl, + transl_block f bb ep = OK (tbb1::tbb2::nil) -> + is_label lbl tbb1 = MB.is_label lbl bb + /\ is_label lbl tbb2 = false. +Proof. + intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. +Qed. + +Lemma transl_block_nonil: + forall f c ep tc, + transl_block f c ep = OK tc -> + tc <> nil. +Proof. + intros. monadInv H. unfold gen_bblocks. + destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. + all: discriminate. +Qed. + +Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, + ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). +Proof. + intros. intro. monadInv H. + unfold gen_bblocks in H0. + destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. + all: discriminate. +Qed. + +Lemma find_label_transl_false: + forall x f lbl bb ep x', + transl_block f bb ep = OK x -> + MB.is_label lbl bb = false -> + find_label lbl (x++x') = find_label lbl x'. +Proof. + intros until x'. intros TLB MBis; simpl; auto. + destruct x as [|x0 x1]; simpl; auto. + destruct x1 as [|x1 x2]; simpl; auto. + - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. + - destruct x2 as [|x2 x3]; simpl; auto. + + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. + erewrite transl_is_label_false2; eauto. + + apply transl_block_limit in TLB. destruct TLB. +Qed. + +Lemma transl_blocks_label: + forall lbl f c tc ep, + transl_blocks f c ep = OK tc -> + match MB.find_label lbl c with + | None => find_label lbl tc = None + | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' + end. +Proof. + induction c; simpl; intros. + inv H. auto. + monadInv H. + destruct (MB.is_label lbl a) eqn:MBis. + - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } + simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. + rewrite ABis. + eexists. eexists. split; eauto. simpl transl_blocks. + assert (MB.header a <> nil). + { apply MB.is_label_correct_true in MBis. + destruct (MB.header a). contradiction. discriminate. } + destruct (MB.header a); try contradiction. + rewrite EQ. simpl. rewrite EQ1. simpl. auto. + - apply IHc in EQ1. destruct (MB.find_label lbl c). + + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. + erewrite find_label_transl_false; eauto. + + erewrite find_label_transl_false; eauto. +Qed. + +Lemma find_label_nil: + forall bb lbl c, + header bb = nil -> + find_label lbl (bb::c) = find_label lbl c. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. subst. + assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { erewrite <- is_label_correct_false. simpl. auto. } + rewrite H. auto. +Qed. + +Theorem transl_find_label: + forall lbl f tf, + transf_function f = OK tf -> + match MB.find_label lbl f.(MB.fn_code) with + | None => find_label lbl tf.(fn_blocks) = None + | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc + end. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. + monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. + eapply transl_blocks_label; eauto. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Machblock code translates to a valid ``go to'' + transition in the generated Asmblock code. *) + +Lemma find_label_goto_label: + forall f tf lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + transf_function f = OK tf -> + rs PC = Vptr b ofs -> + MB.find_label lbl f.(MB.fn_code) = Some c' -> + exists tc', exists rs', + goto_label tf lbl rs m = Next rs' m + /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. + intros (tc & A & B). + exploit label_pos_code_tail; eauto. instantiate (1 := 0). + intros [pos' [P [Q R]]]. + exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). + split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. + split. rewrite Pregmap.gss. constructor; auto. + rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. + auto. omega. + generalize (transf_function_no_overflow _ _ H0). omega. + intros. apply Pregmap.gso; auto. +Qed. + +(** Existence of return addresses *) + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. eapply Asmblockgenproof0.return_address_exists; eauto. + +- intros. monadInv H0. + destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. + exists x; exists true; split; auto. + repeat constructor. +- exact transf_function_no_overflow. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using a complex simulation diagram + of the following form. +<< + MB.step + ----------------------------------------> + header body exit + st1 -----> st2 -----> st3 ------------------> st4 + | | | | + | (A) | (B) | (C) | + match_codestate | | | | + | header | body1 | body2 | match_states + cs1 -----> cs2 -----> cs3 ------> cs4 | + | / \ exit | + match_asmstate | --------------- --->--- | + | / match_asmstate \ | + st'1 ---------------------------------------> st'2 + AB.step * +>> + The invariant between each MB.step/AB.step is the [match_states] predicate below. + However, we also need to introduce an intermediary state [Codestate] which allows + us to reason on a finer grain, executing header, body and exit separately. + + This [Codestate] consists in a state like [Asmblock.State], except that the + code is directly stored in the state, much like [Machblock.State]. It also features + additional useful elements to keep track of while executing a bblock. +*) + +Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. +Proof. + intros. change (IR FP) with (preg_of MFP). red; intros. + exploit preg_of_injective; eauto. intros; subst r; discriminate. +Qed. + +Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := + | match_states_intro: + forall s fb sp c ep ms m m' rs f tf tc + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m') + (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) + (AG: agree ms sp rs) + (DXP: ep = true -> rs#FP = parent_sp s), + match_states (Machblock.State s fb sp c ms m) + (Asmvliw.State rs m') + | match_states_call: + forall s fb ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Ptrofs.zero) + (ATLR: rs RA = parent_ra s), + match_states (Machblock.Callstate s fb ms m) + (Asmvliw.State rs m') + | match_states_return: + forall s ms m m' rs + (STACKS: match_stack ge s) + (MEXT: Mem.extends m m') + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machblock.Returnstate s ms m) + (Asmvliw.State rs m'). + +Record codestate := + Codestate { pstate: state; (**r projection to Asmblock.state *) + pheader: list label; + pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) + pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) + pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) + ep: bool; (**r reflects the [ep] variable used in the translation *) + rem: list AB.bblock; (**r remaining bblocks to execute *) + cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) + }. + +(* The part that deals with Machblock <-> Codestate agreement + * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) +Inductive match_codestate fb: Machblock.state -> codestate -> Prop := + | match_codestate_intro: + forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi + (STACKS: match_stack ge s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (MEXT: Mem.extends m m0) + (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) + (TIC: transl_instr_control f (MB.exit bb) = OK tbi) + (TBLS: transl_blocks f c false = OK tc) + (AG: agree ms sp rs0) + (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) + , + match_codestate fb (Machblock.State s fb sp (bb::c) ms m) + {| pstate := (Asmvliw.State rs0 m0); + pheader := (MB.header bb); + pbody1 := tbc; + pbody2 := extract_basic tbi; + pctl := extract_ctl tbi; + ep := ep; + rem := tc; + cur := tbb + |} +. + +(* The part ensuring that the code in Codestate actually resides at [rs PC] *) +Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := + | match_asmstate_some: + forall rs f tf tc m tbb ofs ep tbdy tex lhd + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (TRANSF: transf_function f = OK tf) + (PCeq: rs PC = Vptr fb ofs) + (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) + , + match_asmstate fb + {| pstate := (Asmvliw.State rs m); + pheader := lhd; + pbody1 := tbdy; + pbody2 := extract_basic tex; + pctl := extract_ctl tex; + ep := ep; + rem := tc; + cur := tbb |} + (Asmvliw.State rs m) +. + +(* Useful for dealing with the many cases in some proofs *) +Ltac exploreInst := + repeat match goal with + | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var + | [ H : OK _ = OK _ |- _ ] => monadInv H + | [ |- context[if ?b then _ else _] ] => destruct b + | [ |- context[match ?m with | _ => _ end] ] => destruct m + | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m + | [ H : bind _ _ = OK _ |- _ ] => monadInv H + | [ H : Error _ = OK _ |- _ ] => inversion H + end. + +(** Some translation properties *) + +Lemma transl_blocks_nonil: + forall f bb c tc ep, + transl_blocks f (bb::c) ep = OK tc -> + exists tbb tc', tc = tbb :: tc'. +Proof. + intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. + destruct (extract_ctl x2). + - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. + - destruct x1; simpl; eauto. +Qed. + +Lemma no_builtin_preserved: + forall f ex x2, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x2 -> + (exists i, extract_ctl x2 = Some (PCtlFlow i)) + \/ extract_ctl x2 = None. +Proof. + intros until x2. intros Hbuiltin TIC. + destruct ex. + - destruct c. + (* MBcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBtailcall *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBbuiltin *) + + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). + apply Hbuiltin. contradict H; auto. + (* MBgoto *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBcond *) + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. + * unfold transl_opt_compuimm. exploreInst; simpl; eauto. + * unfold transl_opt_compluimm. exploreInst; simpl; eauto. + * unfold transl_comp_float64. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. + * unfold transl_comp_float32. exploreInst; simpl; eauto. + * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. + (* MBjumptable *) + + simpl in TIC. exploreInst; simpl; eauto. + (* MBreturn *) + + simpl in TIC. monadInv TIC. simpl. eauto. + - monadInv TIC. simpl; auto. +Qed. + +Lemma transl_blocks_distrib: + forall c f bb tbb tc ep, + transl_blocks f (bb::c) ep = OK (tbb::tc) + -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) + -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) + /\ transl_blocks f c false = OK tc. +Proof. + intros until ep0. intros TLBS Hbuiltin. + destruct bb as [hd bdy ex]. + monadInv TLBS. monadInv EQ. + exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. + - destruct H as [i Hectl]. + unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. + simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite Hectl. auto. + - unfold gen_bblocks in H0. rewrite H in H0. + destruct x1 as [|bi x1]. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. + + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. + unfold gen_bblocks. rewrite H. auto. +Qed. + +Lemma gen_bblocks_nobuiltin: + forall thd tbdy tex tbb, + (tbdy <> nil \/ extract_ctl tex <> None) -> + (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> + gen_bblocks thd tbdy tex = tbb :: nil -> + header tbb = thd + /\ body tbb = tbdy ++ extract_basic tex + /\ exit tbb = extract_ctl tex. +Proof. + intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. + destruct (extract_ctl tex) eqn:ECTL. + - destruct c. + + destruct i; try (inv GENB; simpl; auto; fail). + assert False. eapply Hnobuiltin. eauto. destruct H. + + inv GENB. simpl. auto. + - inversion Hnonil. + + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. + + contradict H; simpl; auto. +Qed. + +Lemma transl_instr_basic_nonil: + forall k f bi ep x, + transl_instr_basic f bi ep k = OK x -> + x <> nil. +Proof. + intros until x. intros TIB. + destruct bi. + - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. + - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. + - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. + - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. + unfold transl_cond_op in EQ0. exploreInst; try discriminate. + unfold transl_cond_float64. exploreInst; try discriminate. + unfold transl_cond_notfloat64. exploreInst; try discriminate. + unfold transl_cond_float32. exploreInst; try discriminate. + unfold transl_cond_notfloat32. exploreInst; try discriminate. + - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. + - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. + all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. +Qed. + +Lemma transl_basic_code_nonil: + forall bdy f x ep, + bdy <> nil -> + transl_basic_code f bdy ep = OK x -> + x <> nil. +Proof. + induction bdy as [|bi bdy]. + intros. contradict H0; auto. + destruct bdy as [|bi2 bdy]. + - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. + - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. + monadInv TBC. + assert (x0 <> nil). + eapply IHbdy; eauto. subst bdy'. discriminate. + eapply transl_instr_basic_nonil; eauto. +Qed. + +Lemma transl_instr_control_nonil: + forall ex f x, + ex <> None -> + transl_instr_control f ex = OK x -> + extract_ctl x <> None. +Proof. + intros ex f x Hnonil TIC. + destruct ex as [ex|]. + - clear Hnonil. destruct ex. + all: try (simpl in TIC; exploreInst; discriminate). + + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. + * unfold transl_opt_compuimm. exploreInst; try discriminate. + * unfold transl_opt_compluimm. exploreInst; try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. + - contradict Hnonil; auto. +Qed. + +Lemma transl_instr_control_nobuiltin: + forall f ex x, + (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> + transl_instr_control f ex = OK x -> + (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). +Proof. + intros until x. intros Hnobuiltin TIC. intros until res. + unfold transl_instr_control in TIC. exploreInst. + all: try discriminate. + - assert False. eapply Hnobuiltin; eauto. destruct H. + - unfold transl_cbranch in TIC. exploreInst. + all: try discriminate. + * unfold transl_opt_compuimm. exploreInst. all: try discriminate. + * unfold transl_opt_compluimm. exploreInst. all: try discriminate. + * unfold transl_comp_float64. exploreInst; try discriminate. + * unfold transl_comp_notfloat64. exploreInst; try discriminate. + * unfold transl_comp_float32. exploreInst; try discriminate. + * unfold transl_comp_notfloat32. exploreInst; try discriminate. +Qed. + +(* Proving that one can decompose a [match_state] relation into a [match_codestate] + and a [match_asmstate], along with some helpful properties tying both relations together *) + +Theorem match_state_codestate: + forall mbs abs s fb sp bb c ms m, + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + (MB.body bb <> nil \/ MB.exit bb <> None) -> + mbs = (Machblock.State s fb sp (bb::c) ms m) -> + match_states mbs abs -> + exists cs fb f tbb tc ep, + match_codestate fb mbs cs /\ match_asmstate fb cs abs + /\ Genv.find_funct_ptr ge fb = Some (Internal f) + /\ transl_blocks f (bb::c) ep = OK (tbb::tc) + /\ body tbb = pbody1 cs ++ pbody2 cs + /\ exit tbb = pctl cs + /\ cur cs = tbb /\ rem cs = tc + /\ pstate cs = abs. +Proof. + intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. + inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. + exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. + monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. + { inversion Hnotempty. + - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). + left. eapply transl_basic_code_nonil; eauto. + - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). + right. eapply transl_instr_control_nonil; eauto. } + eapply transl_instr_control_nobuiltin; eauto. + intros (Hth & Htbdy & Htexit). + exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; + pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. + repeat split. 1-2: econstructor; eauto. + { destruct (MB.header bb). eauto. discriminate. } eauto. + unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. + rewrite TLBS. simpl. rewrite H2. + all: simpl; auto. +Qed. + +Definition mb_remove_body (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. + +Lemma exec_straight_pnil: + forall c rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> + exec_straight tge c rs1 m1 nil rs2 m2. +Proof. + intros. eapply exec_straight_trans. eapply H. econstructor; eauto. +Qed. + +Lemma transl_block_nobuiltin: + forall f bb ep tbb, + (MB.body bb <> nil \/ MB.exit bb <> None) -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + transl_block f bb ep = OK (tbb :: nil) -> + exists c c', + transl_basic_code f (MB.body bb) ep = OK c + /\ transl_instr_control f (MB.exit bb) = OK c' + /\ body tbb = c ++ extract_basic c' + /\ exit tbb = extract_ctl c'. +Proof. + intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. + - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. + right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. +Qed. + +Lemma nextblock_preserves: + forall rs rs' bb r, + rs' = nextblock bb rs -> + data_preg r = true -> + rs r = rs' r. +Proof. + intros. destruct r; try discriminate. + subst. Simpl. +Qed. + +Remark cons3_app {A: Type}: + forall a b c (l: list A), + a :: b :: c :: l = (a :: b :: c :: nil) ++ l. +Proof. + intros. simpl. auto. +Qed. + +Lemma exec_straight_opt_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight_opt tge c rs1 m1 c' rs2 m2 -> + exists body, + exec_body tge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. intros EXES. + inv EXES. + - exists nil. split; auto. + - eapply exec_straight_body2. auto. +Qed. + +Lemma extract_basics_to_code: + forall lb c, + extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +Lemma extract_ctl_basics_to_code: + forall lb c, + extract_ctl (basics_to_code lb ++ c) = extract_ctl c. +Proof. + induction lb; intros; simpl; congruence. +Qed. + +(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are + unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by + yourself the steps *) +Theorem step_simu_control: + forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, + MB.body bb' = nil -> + (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> + Genv.find_funct_ptr tge fb = Some (Internal fn) -> + pstate cs2 = (Asmvliw.State rs2 m2) -> + pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> + cur cs2 = tbb -> + match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> + match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> + exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> + (exists rs3 m3 rs4 m4, + exec_body tge tbdy2 rs2 m2 = Next rs3 m3 + /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 + /\ match_states S'' (State rs4 m4)). +Proof. + intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. + inv ESTEP. + - inv MCS. inv MAS. simpl in *. + inv Hpstate. + destruct ctl. + + (* MBcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + destruct s1 as [rf|fid]; simpl in H7. + * (* Indirect call *) + monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. + revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + { econstructor; eauto. } + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. + + * (* Direct call *) + monadInv H1. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + remember (Ptrofs.add _ _) as ofs'. + assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). + econstructor; eauto. + assert (f1 = f) by congruence. subst f1. + exploit return_address_offset_correct; eauto. intros; subst ra. + repeat eexists. + rewrite H6. econstructor; eauto. + rewrite H7. econstructor; eauto. + econstructor; eauto. + econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. + Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. + Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. + + (* MBtailcall *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. + destruct s1 as [rf|fid]; simpl in H13. + * monadInv H1. + assert (ms' rf = Vptr f' Ptrofs.zero). + { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } + assert (rs2 x = Vptr f' Ptrofs.zero). + { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } + + assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + { simpl. eauto. } + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). + { clear - EQ. destruct x; repeat split; try discriminate. + all: unfold ireg_of in EQ; destruct rf; try discriminate. } + Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. + * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + { apply agree_set_other. + - econstructor; auto with asmgen. + + apply V. + + intro r. destruct r; apply V; auto. + - eauto with asmgen. } + { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } + + (* MBbuiltin (contradiction) *) + assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). + rewrite <- H in H1. contradict H1; auto. + + (* MBgoto *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. + remember (nextblock tbb rs2) as rs2'. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + exploit find_label_goto_label. + eauto. eauto. + instantiate (2 := rs2'). + { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } + eauto. + intros (tc' & rs' & GOTO & AT2 & INV). + + eexists. eexists. repeat eexists. repeat split. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. + econstructor; eauto. + rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. + eapply agree_exten; eauto with asmgen. + assert (forall r : preg, r <> PC -> rs' r = rs2 r). + { intros. destruct r. + - destruct g. all: rewrite INV; Simpl; auto. + - rewrite INV; Simpl; auto. + - contradiction. } + eauto with asmgen. + congruence. + + (* MBcond *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + * (* MBcond true *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. + 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. + unfold Val.offset_ptr. rewrite PCeq. eauto. + intros (tc' & rs3 & GOTOL & TLPC & Hrs3). + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + * (* MBcond false *) + assert (f0 = f) by congruence. subst f0. + exploit eval_condition_lessdef. + eapply preg_vals; eauto. + all: eauto. + intros EC. + + exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). + exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). + assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } + rewrite PCeq' in PCeq. + exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. + assert (tf = fn) by congruence. subst tf. + + assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. + + repeat eexists. + rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. + rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. + + econstructor; eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. + eapply agree_exten with rs2; eauto with asmgen. + { intros. destruct r; try destruct g; try discriminate. + all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } + intros. discriminate. + + (* MBjumptable *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + monadInv H1. + generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. + assert (f1 = f) by congruence. subst f1. + exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. + exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. + + intros [tc' [rs' [A [B C]]]]. + exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. + + repeat eexists. + rewrite H6. simpl extract_basic. simpl. eauto. + rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. + econstructor; eauto. + eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. + { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. + destruct (preg_eq r' GPR63). subst. contradiction. + destruct (preg_eq r' GPR62). subst. contradiction. + destruct r'; Simpl. } + discriminate. + + (* MBreturn *) + destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. + inv TBC. inv TIC. inv H0. + + assert (f0 = f) by congruence. subst f0. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). + exploit exec_straight_body; eauto. + simpl. eauto. + intros EXEB. + assert (f1 = f) by congruence. subst f1. + + repeat eexists. + rewrite H6. simpl extract_basic. eauto. + rewrite H7. simpl extract_ctl. simpl. reflexivity. + econstructor; eauto. + unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. + + - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. + destruct bb' as [hd' bdy' ex']; simpl in *. subst. + monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. + simpl. repeat eexists. + econstructor. 4: instantiate (3 := false). all:eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + assert (f = f0) by congruence. subst f0. econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + discriminate. +Qed. + +Definition mb_remove_first (bb: MB.bblock) := + {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. + +Lemma exec_straight_body: + forall c c' lc rs1 m1 rs2 m2, + exec_straight tge c rs1 m1 c' rs2 m2 -> + code_to_basics c = Some lc -> + exists l ll, + c = l ++ c' + /\ code_to_basics l = Some ll + /\ exec_body tge ll rs1 m1 = Next rs2 m2. +Proof. + induction c; try (intros; inv H; fail). + intros until m2. intros EXES CTB. inv EXES. + - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. + - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. + eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. + exists (i ::g l'),(i::ll). repeat (split; simpl; auto). + rewrite CTB. auto. + rewrite H1. auto. +Qed. + +Lemma basics_to_code_app: + forall c l x ll, + basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + c = ll ++ x. +Proof. + intros. apply (f_equal code_to_basics) in H. + erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. + rewrite code_to_basics_id in H. inv H. auto. +Qed. + +Lemma basics_to_code_app2: + forall i c l x ll, + (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> + code_to_basics l = Some ll -> + i :: c = ll ++ x. +Proof. + intros until ll. intros. + exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. + all: eauto. +Qed. + +(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) +Theorem step_simu_basic: + forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, + MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> + basic_step ge s fb sp ms m bi ms' m' -> + pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 l cs2 tbdy', + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} + /\ tbdy = l ++ tbdy' + /\ exec_body tge l rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). +Proof. + intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. + simpl in *. inv Hpstate. + rewrite Hbody in TBC. monadInv TBC. + inv BSTEP. + + - (* MBgetstack *) + simpl in EQ0. + unfold Mach.load_stack in H. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ AG) in A. + exploit loadind_correct; eauto with asmgen. + intros (rs2 & EXECS & Hrs'1 & Hrs'2). + eapply exec_straight_body in EXECS. + 2: eapply code_to_basics_id; eauto. + destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). + exists rs2, m1, Hlbi. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. simpl in Hheadereq. + + eapply match_codestate_intro; eauto. + { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. + discriminate. apply preg_of_not_FP; assumption. reflexivity. + + - (* MBsetstack *) + simpl in EQ0. + unfold Mach.store_stack in H. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } + exploit Mem.storev_extends; eauto. intros [m2' [A B]]. + exploit storeind_correct; eauto with asmgen. + rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs', m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + + eapply agree_undef_regs; eauto with asmgen. + simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. + - (* MBgetparam *) + simpl in EQ0. + + assert (f0 = f) by congruence; subst f0. + unfold Mach.load_stack in *. + exploit Mem.loadv_extends. eauto. eexact H0. auto. + intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. + exploit Mem.loadv_extends. eauto. eexact H1. auto. + intros [v' [C D]]. + + monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. + destruct ep0 eqn:EPeq. + + (* RTMP contains parent *) + + exploit loadind_correct. eexact EQ1. + instantiate (2 := rs1). rewrite DXP; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & BTC & CTB & EXECB). + exists rs2, m1, ll. eexists. + eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + { eapply basics_to_code_app; eauto. } + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } + subst. + eapply match_codestate_intro; eauto. + + eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. + simpl; intros. rewrite R; auto with asmgen. + apply preg_of_not_FP; auto. + + (* RTMP does not contain parent *) + + rewrite chunk_of_Tptr in A. + exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. + exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. + intros [rs3 [S [T U]]]. + + exploit exec_straight_trans. + eapply P. + eapply S. + intros EXES. + + eapply exec_straight_body in EXES. + 2: simpl. 2: erewrite code_to_basics_id; eauto. + destruct EXES as (l & ll & BTC & CTB & EXECB). + exists rs3, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app2; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. + eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. + instantiate (1 := rs2#FP <- (rs3#FP)). intros. + rewrite Pregmap.gso; auto with asmgen. + congruence. + intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. + simpl; intros. rewrite U; auto with asmgen. + apply preg_of_not_FP; auto. + - (* MBop *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_operation tge sp op (map ms args) m' = Some v). + rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. + exploit eval_operation_lessdef. + eapply preg_vals; eauto. + 2: eexact H0. + all: eauto. + intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. + apply agree_set_undef_mreg with rs1; auto. + apply Val.lessdef_trans with v'; auto. + simpl; intros. destruct (andb_prop _ _ H1); clear H1. + rewrite R; auto. apply preg_of_not_FP; auto. +Local Transparent destroyed_by_op. + destruct op; simpl; auto; congruence. + - (* MBload *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + exploit Mem.loadv_extends; eauto. intros [v' [C D]]. + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_set_mreg; eauto with asmgen. + intro Hep. simpl in Hep. + destruct (andb_prop _ _ Hep). clear Hep. + subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. + apply preg_of_not_FP; assumption. reflexivity. + + - (* notrap1 cannot happen *) + simpl in EQ0. unfold transl_load in EQ0. + destruct addr; simpl in H. + all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; + monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; + destruct args as [|h0 t0]; try discriminate; + destruct t0 as [|h1 t1]; try discriminate; + destruct t1 as [|h2 t2]; try discriminate. + + - (* MBload notrap2 TODO *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + + destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. + { + exploit transl_load_correct; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. + simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. + } + { + exploit transl_load_correct_notrap2; eauto. + intros [rs2 [P [Q R]]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m1, ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. +(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + rewrite <- Hheadereq. *) subst. + eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. + + eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. + simpl. intro. + rewrite R; try congruence. + apply DXP. + destruct ep0; simpl in *; congruence. + apply preg_of_not_FP. + destruct ep0; simpl in *; congruence. + } + - (* MBstore *) + simpl in EQ0. rewrite Hheader in DXP. + + assert (eval_addressing tge sp addr (map ms args) = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. + intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. + assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. + exploit Mem.storev_extends; eauto. intros [m2' [C D]]. + exploit transl_store_correct; eauto. intros [rs2 [P Q]]. + + eapply exec_straight_body in P. + 2: eapply code_to_basics_id; eauto. + destruct P as (l & ll & TBC & CTB & EXECB). + exists rs2, m2', ll. + eexists. eexists. split. instantiate (1 := x). eauto. + repeat (split; auto). + eapply basics_to_code_app; eauto. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. + assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } + subst. + eapply match_codestate_intro; eauto. simpl. simpl in EQ. + rewrite <- Hheadereq in EQ. assumption. + eapply agree_undef_regs; eauto with asmgen. + intro Hep. simpl in Hep. + subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. +Qed. + +Lemma exec_body_trans: + forall l l' rs0 m0 rs1 m1 rs2 m2, + exec_body tge l rs0 m0 = Next rs1 m1 -> + exec_body tge l' rs1 m1 = Next rs2 m2 -> + exec_body tge (l++l') rs0 m0 = Next rs2 m2. +Proof. + induction l. + - simpl. congruence. + - intros until m2. intros EXEB1 EXEB2. + inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. + simpl. rewrite EBI. eapply IHl; eauto. +Qed. + +Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. + +Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. +Next Obligation. + destruct tbb. simpl. auto. +Qed. + +Inductive exec_header: codestate -> codestate -> Prop := + | exec_header_cons: forall cs1, + exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; + cur := cur cs1 |}. + +(* Theorem (A) in the diagram, the easiest of all *) +Theorem step_simu_header: + forall bb s fb sp c ms m rs1 m1 cs1, + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists cs1', + exec_header cs1 cs1' + /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). +Proof. + intros until cs1. intros Hpstate MCS. + eexists. split; eauto. + econstructor; eauto. + inv MCS. simpl in *. inv Hpstate. + econstructor; eauto. +Qed. + +Lemma step_matchasm_header: + forall fb cs1 cs1' s1, + match_asmstate fb cs1 s1 -> + exec_header cs1 cs1' -> + match_asmstate fb cs1' s1. +Proof. + intros until s1. intros MAS EXH. + inv MAS. inv EXH. + simpl. econstructor; eauto. +Qed. + +(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) +Theorem step_simu_body: + forall bb s fb sp c ms m rs1 m1 ms' cs1 m', + MB.header bb = nil -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + body_step ge s fb sp (MB.body bb) ms m ms' m' -> + pstate cs1 = (State rs1 m1) -> + match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> + (exists rs2 m2 cs2 ep, + cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; + pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} + /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 + /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). +Proof. + intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. + inv BSTEP. + exists rs1, m1, cs1, (ep cs1). + inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). + econstructor; eauto. + - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. + rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. + exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. + intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). + simpl in *. + exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. + intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). + exists rs3, m3, cs3, ep. + repeat (split; simpl; auto). subst. simpl in *. auto. + rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. +Qed. + +Lemma exec_body_control: + forall b rs1 m1 rs2 m2 rs3 m3 fn, + exec_body tge (body b) rs1 m1 = Next rs2 m2 -> + exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> + exec_bblock_rel tge fn b rs1 m1 rs3 m3. +Proof. + intros until fn. intros EXEB EXECTL. + econstructor; eauto. inv EXECTL. + unfold exec_bblock. rewrite EXEB. auto. +Qed. + +Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. + +Lemma mbsize_eqz: + forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. + remember (length _) as a. remember (length_opt _) as b. + assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. + inv H0. inv H1. destruct bdy; destruct ex; auto. + all: try discriminate. +Qed. + +Lemma mbsize_neqz: + forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). +Proof. + intros. destruct bb as [hd bdy ex]; simpl in *. + destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). + contradict H. unfold mbsize. simpl. auto. +Qed. + +(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) +(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) +Lemma step_simulation_bblock': + forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, + bb' = mb_remove_header bb -> + body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> + bb'' = mb_remove_body bb' -> + (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. +Proof. + intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. + destruct (mbsize bb) eqn:SIZE. + - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). + destruct bb as [hd bdy ex]; simpl in *; subst. + inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. + monadInv H2. simpl in *. inv ESTEP. inv BSTEP. + eexists. split. eapply plus_one. + exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. + assert (x = tf) by congruence. subst x. + eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. + unfold exec_bblock. simpl. eauto. + econstructor. eauto. eauto. eauto. + unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. + assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + econstructor; eauto. + generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. + eapply agree_exten; eauto. intros. Simpl. + intros. discriminate. + - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } + intros Hnotempty. + + (* initial setting *) + exploit match_state_codestate. + 2: eapply Hnotempty. + all: eauto. + intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). + + (* step_simu_header part *) + assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } + destruct H as (rs1 & m1 & Hpstate2). subst. + assert (f = fb). { inv MCS. auto. } subst fb. + exploit step_simu_header. + 2: eapply MCS. + all: eauto. + intros (cs1' & EXEH & MCS2). + + (* step_simu_body part *) + assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } + exploit step_simu_body. + 3: eapply BSTEP. + 4: eapply MCS2. + all: eauto. rewrite Hpstate'. eauto. + intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). + + (* step_simu_control part *) + assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). + { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } + destruct H as (tf & FIND'). + assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). + { inv MAS. simpl in *. eauto. } + destruct H as (tex & Hpbody2 & Hpctl). + inv EXEH. simpl in *. + subst. exploit step_simu_control. + 9: eapply MCS'. all: simpl. + 10: eapply ESTEP. + all: simpl; eauto. + rewrite Hpbody2. rewrite Hpctl. + { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. + erewrite exec_body_pc; eauto. } + intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). + + (* bringing the pieces together *) + exploit exec_body_trans. + eapply EXEB. + eauto. + intros EXEB2. + exploit exec_body_control; eauto. + rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. + rewrite Hexit. rewrite Hpctl. eauto. + intros EXECB. inv EXECB. + exists (State rs4 m4). + split; auto. eapply plus_one. rewrite Hpstate2. + assert (exists ofs, rs1 PC = Vptr f ofs). + { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } + destruct H0 as (ofs & Hrs1pc). + eapply exec_step_internal; eauto. + + (* proving the initial find_bblock *) + rewrite Hpstate2 in MAS. inv MAS. simpl in *. + assert (f1 = f0) by congruence. subst f0. + rewrite PCeq in Hrs1pc. inv Hrs1pc. + exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. + inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. + eapply find_bblock_tail; eauto. +Qed. + +Theorem step_simulation_bblock: + forall sf f sp bb ms m ms' m' S2 c, + body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> + (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> + exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. +Proof. + intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. + eapply step_simulation_bblock'; eauto. + all: destruct bb as [hd bdy ex]; simpl in *; eauto. + inv ESTEP. + - econstructor. inv H; try (econstructor; eauto; fail). + - econstructor. +Qed. + +(** Dealing now with the builtin case *) + +Definition split (c: MB.code) := + match c with + | nil => nil + | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} + :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c + end. + +Lemma cons_ok_eq3 {A: Type} : + forall (x:A) y z x' y' z', + x = x' -> y = y' -> z = z' -> + OK (x::y::z) = OK (x'::y'::z'). +Proof. + intros. subst. auto. +Qed. + +Lemma transl_blocks_split_builtin: + forall bb c ep f ef args res, + MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> + transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. +Proof. + intros until res. intros Hexit Hbody. simpl split. + unfold transl_blocks. fold transl_blocks. unfold transl_block. + simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. + remember (transl_blocks _ _ _) as tlbs. + destruct tbc; destruct tbi; destruct tlbs. + all: try simpl; auto. + - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. + unfold gen_bblocks. simpl. destruct l. + + exploit transl_basic_code_nonil; eauto. intro. destruct H. + + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. +Qed. + +Lemma transl_code_at_pc_split_builtin: + forall rs f f0 bb c ep tf tc ef args res, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> + transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. +Proof. + intros until res. intros Hbody Hexit AT. inv AT. + econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. +Qed. + +Theorem match_states_split_builtin: + forall sf f sp bb c rs m ef args res S1, + MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> + match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. +Proof. + intros until S1. intros Hbody Hexit MS. + inv MS. + econstructor; eauto. + eapply transl_code_at_pc_split_builtin; eauto. +Qed. + +Theorem step_simulation_builtin: + forall ef args res bb sf f sp c ms m t S2, + MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> + exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> + forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> + exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. +Proof. + intros until S2. intros Hbody Hexit ESTEP S1' MS. + inv MS. inv AT. monadInv H2. monadInv EQ. + rewrite Hbody in EQ0. monadInv EQ0. + rewrite Hexit in EQ. monadInv EQ. + rewrite Hexit in ESTEP. inv ESTEP. inv H4. + + exploit functions_transl; eauto. intro FN. + generalize (transf_function_no_overflow _ _ H1); intro NOOV. + exploit builtin_args_match; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2' [A [B [C D]]]]]. + econstructor; split. apply plus_one. + simpl in H3. + eapply exec_step_builtin. eauto. eauto. + eapply find_bblock_tail; eauto. + simpl. eauto. + erewrite <- sp_val by eauto. + eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eauto. + econstructor; eauto. + instantiate (2 := tf); instantiate (1 := x0). + unfold nextblock, incrPC. rewrite Pregmap.gss. + rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. + rewrite <- H. simpl. econstructor; eauto. + eapply code_tail_next_int; eauto. + rewrite preg_notin_charact. intros. auto with asmgen. + auto with asmgen. + apply agree_nextblock. eapply agree_set_res; auto. + eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. + apply Pregmap.gso; auto with asmgen. + congruence. +Qed. + +Lemma next_sep: + forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + congruence. +Qed. + +(* Measure to prove finite stuttering, see the other backends *) +Definition measure (s: MB.state) : nat := + match s with + | MB.State _ _ _ _ _ _ => 0%nat + | MB.Callstate _ _ _ _ => 0%nat + | MB.Returnstate _ _ _ => 1%nat + end. + +(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs + for the internal and external function cases *) +Theorem step_simulation: + forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> + forall S1' (MS: match_states S1 S1'), + (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') + \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. +Proof. + induction 1; intros. + +- (* bblock *) + left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. + all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; + try (rewrite MBE; try discriminate); eauto). + + (* MBbuiltin *) + destruct (MB.body bb) eqn:MBB. + * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. + * eapply match_states_split_builtin in MS; eauto. + 2: rewrite MBB; discriminate. + simpl split in MS. + rewrite <- MBB in H. + remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. + assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } + rewrite H1 in H. subst. + exploit step_simulation_bblock. eapply H. + discriminate. + simpl. constructor. + eauto. + intros (S2' & PLUS1 & MS'). + rewrite MBE in MS'. + assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) + (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) + rs' m') t s'). + { inv H0. inv H3. econstructor. econstructor; eauto. } + exploit step_simulation_builtin. + 4: eapply MS'. + all: simpl; eauto. + intros (S3' & PLUS'' & MS''). + exists S3'. split; eauto. + eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. + + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. + +- (* internal function *) + inv MS. + exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. + generalize EQ; intros EQ'. monadInv EQ'. + destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. + unfold Mach.store_stack in *. + exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. + intros [m1' [C D]]. + exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. + intros [m2' [F G]]. + simpl chunk_of_type in F. + exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. + intros [m3' [P Q]]. + (* Execution of function prologue *) + monadInv EQ0. + set (tfbody := make_prologue f x0) in *. + set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. + set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). + exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. + intros (rs' & U' & V'). + exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). + { rewrite chunk_of_Tptr in P. + assert (rs' GPRA = rs0 RA). { apply V'. } + assert (rs' SP = rs2 SP). { apply V'; discriminate. } + rewrite H4. rewrite H3. + rewrite ATLR. + change (rs2 SP) with sp. eexact P. } + intros (rs3 & U & V). + assert (EXEC_PROLOGUE: exists rs3', + exec_straight_blocks tge tf + tf.(fn_blocks) rs0 m' + x0 rs3' m3' + /\ forall r, r <> PC -> rs3' r = rs3 r). + { eexists. split. + - change (fn_blocks tf) with tfbody; unfold tfbody. + econstructor; eauto. unfold exec_bblock. simpl exec_body. + rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. + Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. + rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. + simpl. apply next_sep; eauto. reflexivity. + - intros. destruct V' as (V'' & V'). destruct r. + + Simpl. + destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } + + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. + + contradiction. + } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). + exploit exec_straight_steps_2; eauto using functions_transl. + simpl fn_blocks. simpl fn_blocks in g. omega. constructor. + intros (ofs' & X & Y). + left; exists (State rs3' m3'); split. + eapply exec_straight_steps_1; eauto. + simpl fn_blocks. simpl fn_blocks in g. omega. + constructor. + econstructor; eauto. + rewrite X; econstructor; eauto. + apply agree_exten with rs2; eauto with asmgen. + unfold rs2. + apply agree_set_other; auto with asmgen. + apply agree_change_sp with (parent_sp s). + apply agree_undef_regs with rs0. auto. +Local Transparent destroyed_at_function_entry. + simpl; intros; Simpl. + unfold sp; congruence. + + intros. + assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } + rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. + assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + contradict H3; rewrite H3; unfold data_preg; auto. + intros. rewrite Heqrs3'. rewrite V by auto with asmgen. + assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } + rewrite H4 by auto with asmgen. reflexivity. discriminate. + +- (* external function *) + inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + exploit extcall_arguments_match; eauto. + intros [args' [C D]]. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [P [Q [R S]]]]]. + left; econstructor; split. + apply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. + unfold loc_external_result. + apply agree_set_other; auto. + apply agree_set_pair; auto. + apply agree_undef_caller_save_regs; auto. + +- (* return *) + inv MS. + inv STACKS. simpl in *. + right. split. omega. split. auto. + rewrite <- ATPC in H5. + econstructor; eauto. congruence. +Qed. + +Lemma transf_initial_states: + forall st1, MB.initial_state prog st1 -> + exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) + with (Vptr fb Ptrofs.zero). + econstructor; eauto. + constructor. + apply Mem.extends_refl. + split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. + intros. rewrite Mach.Regmap.gi. auto. + unfold Genv.symbol_address. + rewrite (match_program_main TRANSF). + rewrite symbols_preserved. + unfold ge; rewrite H1. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. assumption. + compute in H1. inv H1. + generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. +Qed. + +Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := + Asmblockgenproof0.return_address_offset. + +Theorem transf_program_correct: + forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_star with (measure := measure). + - apply senv_preserved. + - eexact transf_initial_states. + - eexact transf_final_states. + - exact step_simulation. +Qed. + +End PRESERVATION. diff --git a/kvx/Asmblockgenproof1.v b/kvx/Asmblockgenproof1.v new file mode 100644 index 00000000..74b9b62b --- /dev/null +++ b/kvx/Asmblockgenproof1.v @@ -0,0 +1,2499 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * Proof of correctness for individual instructions *) + +Require Import Coqlib Errors Maps. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op Locations Machblock Conventions. +Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. +Require Import Chunks. + +Import PArithCoercions. + +(** Decomposition of integer constants. *) + +Lemma make_immed32_sound: + forall n, + match make_immed32 n with + | Imm32_single imm => n = imm + end. +Proof. + intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). + predSpec Int.eq Int.eq_spec n lo; auto. +Qed. + +Lemma make_immed64_sound: + forall n, + match make_immed64 n with + | Imm64_single imm => n = imm + end. +Proof. + intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). + predSpec Int64.eq Int64.eq_spec n lo. +- auto. +- set (m := Int64.sub n lo). + set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). + predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). + auto. + auto. +Qed. + + +(** Properties of registers *) + +Lemma ireg_of_not_RTMP: + forall m r, ireg_of m = OK r -> IR r <> IR RTMP. +Proof. + intros. erewrite <- ireg_of_eq; eauto with asmgen. +Qed. + +Lemma ireg_of_not_RTMP': + forall m r, ireg_of m = OK r -> r <> RTMP. +Proof. + intros. apply ireg_of_not_RTMP in H. congruence. +Qed. + +Hint Resolve ireg_of_not_RTMP ireg_of_not_RTMP': asmgen. + + +(** Useful simplification tactic *) + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(** * Correctness of RISC-V constructor functions *) + +Section CONSTRUCTORS. + +Variable ge: genv. +Variable fn: function. + +Lemma loadimm32_correct: + forall rd n k rs m, + exists rs', + exec_straight ge (loadimm32 rd n ::g k) rs m k rs' m + /\ rs'#rd = Vint n + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. + destruct (make_immed32 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + +Lemma loadimm64_correct: + forall rd n k rs m, + exists rs', + exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m + /\ rs'#rd = Vlong n + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. + intros; Simpl. +Qed. + +Lemma opimm64_correct: + forall (op: arith_name_rrr) + (opi: arith_name_rri64) + (sem: val -> val -> val) m, + (forall d s1 s2 rs, + exec_basic_instr ge (op d s1 s2) rs m = Next ((rs#d <- (sem rs#s1 rs#s2))) m) -> + (forall d s n rs, + exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) -> + forall rd r1 n k rs, + r1 <> RTMP -> + exists rs', + exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m + /\ rs'#rd = sem rs#r1 (Vlong n) + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. unfold opimm64. generalize (make_immed64_sound n); intros E. + destruct (make_immed64 n). +- subst imm. econstructor; split. + apply exec_straight_one. rewrite H0. simpl; eauto. auto. + split. Simpl. intros; Simpl. +Qed. + +(** Add offset to pointer *) + +Lemma addptrofs_correct: + forall rd r1 n k rs m, + r1 <> RTMP -> + exists rs', + exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m + /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + unfold addptrofs; intros. + destruct (Ptrofs.eq_dec n Ptrofs.zero). +- subst n. econstructor; split. + apply exec_straight_one. simpl; eauto. auto. + split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. + intros; Simpl. +- unfold addimm64. + exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). + exists rs'; split. eexact A. split; auto. + rewrite B. destruct (rs r1); simpl; auto. + rewrite Ptrofs.of_int64_to_int64 by auto. auto. +Qed. + +Ltac ArgsInv := + repeat (match goal with + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args + | [ H: bind _ _ = OK _ |- _ ] => monadInv H + | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv + end); + subst; + repeat (match goal with + | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * + | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * + end). + +Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop := + | exec_straight_opt_refl: forall c rs m, + exec_straight_opt c rs m c rs m + | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, + exec_straight ge c1 rs1 m1 c2 rs2 m2 -> + exec_straight_opt c1 rs1 m1 c2 rs2 m2. + +Remark exec_straight_opt_right: + forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, + exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> + exec_straight ge c2 rs2 m2 c3 rs3 m3 -> + exec_straight ge c1 rs1 m1 c3 rs3 m3. +Proof. + destruct 1; intros. auto. eapply exec_straight_trans; eauto. +Qed. + +Lemma transl_comp_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compi_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compi cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmp_bool cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compi. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmp_bool cmp rs#r1 (Vint n)) as cmpbool. + destruct cmp; simpl; + unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compu_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (Val_cmpu_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_comp. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmpu_bool cmp rs#r1 rs#r2) as cmpubool. + destruct cmp; simpl; unfold Val_cmpu; + rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compui_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compi cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compi. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmpu_bool cmp rs#r1 (Vint n)) as cmpubool. + destruct cmp; simpl; unfold Val_cmpu; + rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compl_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val.cmpl; + rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compil_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compil cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpl_bool cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compil. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpl_bool cmp rs#r1 (Vlong n)) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val.cmpl; + rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma swap_comparison_cmpf_eq: + forall v1 v2 cmp, + (Val.cmpf cmp v1 v2) = (Val.cmpf (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. + rewrite Float.cmp_swap. auto. +Qed. + +Lemma swap_comparison_cmpf_bool: + forall cmp ft v1 v2, + ftest_for_cmp cmp = Reversed ft -> + Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. +Qed. + +Lemma transl_compf_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_float64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpf_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. unfold transl_comp_float64. destruct (ftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpf_bool in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma cmpf_bool_ne_eq: + forall v1 v2, + Val.cmpf_bool Cne v1 v2 = option_map negb (Val.cmpf_bool Ceq v1 v2). +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. reflexivity. +Qed. + +Lemma cmpf_bool_ne_eq_rev: + forall v1 v2, + Val.cmpf_bool Ceq v1 v2 = option_map negb (Val.cmpf_bool Cne v1 v2). +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. +Qed. + +Lemma option_map_negb_negb: + forall v, + option_map negb (option_map negb v) = v. +Proof. + destruct v; simpl; auto. rewrite negb_involutive. reflexivity. +Qed. + +Lemma notbool_option_map_negb: + forall v, Val.notbool (Val.of_optbool v) = Val.of_optbool (option_map negb v). +Proof. + unfold Val.notbool. unfold Val.of_optbool. + destruct v; auto. destruct b; auto. +Qed. + +Lemma swap_comparison_cmpf_bool_notftest: + forall cmp ft v1 v2, + notftest_for_cmp cmp = Reversed ft -> + Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. +Qed. + +Lemma transl_compnotf_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_notfloat64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. unfold transl_comp_notfloat64. destruct (notftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2)) as cmpbool. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT. + * rewrite cmpf_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite cmpf_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpf_bool_notftest in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_float; + unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma swap_comparison_cmpfs_bool: + forall cmp ft v1 v2, + ftest_for_cmp cmp = Reversed ft -> + Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. +Qed. + +Lemma transl_compfs_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_float32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val.cmpfs_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. unfold transl_comp_float32. destruct (ftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpfs_bool in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma swap_comparison_cmpfs_bool_notftest: + forall cmp ft v1 v2, + notftest_for_cmp cmp = Reversed ft -> + Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. +Qed. + +Lemma cmpfs_bool_ne_eq: + forall v1 v2, + Val.cmpfs_bool Cne v1 v2 = option_map negb (Val.cmpfs_bool Ceq v1 v2). +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. reflexivity. +Qed. + +Lemma cmpfs_bool_ne_eq_rev: + forall v1 v2, + Val.cmpfs_bool Ceq v1 v2 = option_map negb (Val.cmpfs_bool Cne v1 v2). +Proof. + intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. +Qed. + +Lemma transl_compnotfs_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_comp_notfloat32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. unfold transl_comp_notfloat32. destruct (notftest_for_cmp cmp) eqn:FT. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2)) as cmpbool. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT. + * rewrite cmpfs_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite cmpfs_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. + * esplit. split. + - apply exec_straight_one; simpl; eauto. + - split. + + intros; Simpl. + + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. + erewrite swap_comparison_cmpfs_bool_notftest in Heqcmpbool; eauto. + destruct cmp; simpl; + unfold compare_single; + unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_complu_correct: + forall cmp r1 r2 lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val_cmplu_bool cmp rs#r1 rs#r2 = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compl. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmplu_bool cmp rs#r1 rs#r2) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_compilu_correct: + forall cmp r1 n lbl k rs m tbb b, + exists rs', + exec_straight ge (transl_compil cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m + = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. esplit. split. +- unfold transl_compil. apply exec_straight_one; simpl; eauto. +- split. + + intros; Simpl. + + intros. + remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))) as rs'. + simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). + { + assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))). + { rewrite Heqrs'. auto. } + rewrite H0. rewrite <- H. + remember (Val_cmplu_bool cmp rs#r1 (Vlong n)) as cmpbool. + destruct cmp; simpl; + unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; + destruct b0; simpl; auto. + } + rewrite H0. simpl; auto. +Qed. + +Lemma transl_opt_compuimm_correct: + forall n cmp r1 lbl k rs m b tbb c, + select_comp n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. +(* unfold transl_opt_compuimm. unfold select_comp in H. rewrite H; simpl. *) + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compuimm. subst. rewrite H'. + + exists rs, (Pcbu BTweqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. + (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. + { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Cne *) + assert (Int.eq n Int.zero = true) as H'. + { remember (Int.eq n Int.zero) as termz. destruct termz; auto. + generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int.repr 0)) as H0. { + destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. + generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compuimm. subst. rewrite H'. + + exists rs, (Pcbu BTwnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0. auto. + - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); + destruct cmp; discriminate. +Qed. + +Lemma transl_opt_compluimm_correct: + forall n cmp r1 lbl k rs m b tbb c, + select_compl n cmp = Some c -> + exists rs', exists insn, + exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m + /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) + /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> + exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) + . +Proof. + intros. +(* unfold transl_opt_compluimm; rewrite H; simpl. *) + remember c as c'. + destruct c'. + - (* c = Ceq *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Ceq = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compluimm; subst; rewrite H'. + + exists rs, (Pcbu BTdeqz r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Cne *) + assert (Int64.eq n Int64.zero = true) as H'. + { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. + generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. + discriminate. } + assert (n = (Int64.repr 0)) as H0. { + destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. + generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. + rewrite H'. discriminate. + } + assert (Cne = cmp). { + remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; + rewrite H'; simpl; auto; + intros; contradict H; discriminate. + } + unfold transl_opt_compluimm; subst; rewrite H'. + + exists rs, (Pcbu BTdnez r1 lbl). + split. + * constructor. + * split; auto. simpl. intros. + assert (rs r1 = (nextblock tbb rs) r1). + unfold nextblock, incrPC. Simpl. rewrite H1 in H0. + auto; + unfold eval_branch. rewrite H0; auto. + - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. + - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); + destruct cmp; discriminate. +Qed. + +Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. + +Lemma transl_cbranch_correct_1: + forall cond args lbl k c m ms b sp rs m' tbb, + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some b -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = eval_branch fn lbl (nextblock tbb rs') m' (Some b) + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until tbb; intros TRANSL EVAL AG MEXT. + set (vl' := map rs (map preg_of args)). + assert (EVAL': eval_condition cond vl' m' = Some b). + { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } + clear EVAL MEXT AG. + destruct cond; simpl in TRANSL; ArgsInv. +(* Ccomp *) +- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccompu *) +- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; eauto. +(* Ccompimm *) +- remember (Int.eq n Int.zero) as eqz. + destruct eqz. + + assert (n = (Int.repr 0)). { + destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. + generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpswz c0) x lbl). + split. + * constructor. + * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + + exploit (transl_compi_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). + split. + * constructor. eexact A'. + * split; auto. + { apply C'; auto. } +(* Ccompuimm *) +- remember (select_comp n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; auto. apply C. apply EVAL'. + + assert (transl_opt_compuimm n c0 x lbl k = transl_compi c0 Unsigned x n lbl k). + { unfold transl_opt_compuimm. + destruct (Int.eq n Int.zero) eqn:EQN. + all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. + exploit (transl_compui_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). + split. + * constructor. eexact A'. + * split; auto. + { apply C'; auto. } +(* Ccompl *) +- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +(* Ccomplu *) +- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; eauto. +(* Ccomplimm *) +- remember (Int64.eq n Int64.zero) as eqz. + destruct eqz. + + assert (n = (Int64.repr 0)). { + destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. + generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. + rewrite <- Heqeqz. discriminate. + } + exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). + split. + * constructor. + * split; auto. + assert (rs x = (nextblock tbb rs) x). + unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. + destruct c0; simpl; auto; + unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. + + exploit (transl_compil_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). + split. + * constructor. eexact A'. + * split; auto. + { apply C'; auto. } + +(* Ccompluimm *) +- remember (select_compl n c0) as selcomp. + destruct selcomp. + + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. + intros (rs' & i & A & B & C). + exists rs', i. + split. + * apply A. + * split; eauto. (* apply C. apply EVAL'. *) + + assert (transl_opt_compluimm n c0 x lbl k = transl_compil c0 Unsigned x n lbl k). + { unfold transl_opt_compluimm. + destruct (Int64.eq n Int64.zero) eqn:EQN. + all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. + all: discriminate. } + rewrite H. clear H. + exploit (transl_compilu_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). + exists rs'2, (Pcb BTwnez RTMP lbl). + split. + * constructor. eexact A'. + * split; auto. + { apply C'; auto. eapply Val_cmplu_bool_correct; eauto. } + +(* Ccompf *) +- exploit (transl_compf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Cnotcompf *) +- exploit (transl_compnotf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Ccompfs *) +- exploit (transl_compfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. + +(* Cnotcompfs *) +- exploit (transl_compnotfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). + exists rs', (Pcb BTwnez RTMP lbl). + split. + + constructor. eexact A. + + split; auto. apply C; auto. +Qed. + +Lemma transl_cbranch_correct_true: + forall cond args lbl k c m ms sp rs m' tbb, + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some true -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. eapply transl_cbranch_correct_1 with (b := true); eauto. +Qed. + +Lemma transl_cbranch_correct_false: + forall cond args lbl k c m ms sp rs tbb m', + transl_cbranch cond args lbl k = OK c -> + eval_condition cond (List.map ms args) m = Some false -> + agree ms sp rs -> + Mem.extends m m' -> + exists rs', exists insn, + exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' + /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. exploit transl_cbranch_correct_1. all: eauto. simpl eval_branch. instantiate (1 := tbb). + intros (rs' & insn & A & B & C). rewrite regset_same_assign in B. + eexists; eexists. split; try split. all: eassumption. +Qed. + +(** Translation of condition operators *) + +Lemma transl_cond_int32s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int32s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 rs#r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + + +Lemma transl_cond_int32u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ rs'#rd = Val_cmpu cmp rs#r1 rs#r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64s_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int64s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 rs#r2)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_int64u_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ rs'#rd = Val_cmplu cmp rs#r1 rs#r2 + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int32s_correct: + forall cmp rd r1 n k rs m, + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. + +Lemma transl_condimm_int32u_correct: + forall cmp rd r1 n k rs m, + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64s_correct: + forall cmp rd r1 n k rs m, + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_condimm_int64u_correct: + forall cmp rd r1 n k rs m, + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl; + (econstructor; split; + [ apply exec_straight_one; [simpl; eauto] | + split; intros; Simpl; unfold compare_long; eauto]). +Qed. + +Lemma swap_comparison_cmpfs: + forall v1 v2 cmp, + Val.lessdef (Val.cmpfs cmp v1 v2) (Val.cmpfs (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. + rewrite Float32.cmp_swap. auto. +Qed. + +Lemma transl_cond_float32_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_float32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmpfs cmp rs#r1 rs#r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpfs. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpfs. +- econstructor; split. apply exec_straight_one; [simpl; + eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_nofloat32_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_notfloat32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpfs_bool cmp (rs r1) (rs r2)))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float32.cmp_ne_eq. auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float32.cmp_ne_eq. simpl. destruct (Float32.cmp Ceq f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float32.cmp Clt f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float32.cmp_swap. + destruct (Float32.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float32.cmp_swap. + destruct (Float32.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float32.cmp _ _ _); auto. +Qed. + +Lemma swap_comparison_cmpf: + forall v1 v2 cmp, + Val.lessdef (Val.cmpf cmp v1 v2) (Val.cmpf (swap_comparison cmp) v2 v1). +Proof. + intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. + rewrite Float.cmp_swap. auto. +Qed. + +Lemma transl_cond_float64_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_float64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.cmpf cmp rs#r1 rs#r2) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpf. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. apply swap_comparison_cmpf. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. +Qed. + +Lemma transl_cond_nofloat64_correct: + forall cmp rd r1 r2 k rs m, + exists rs', + exec_straight ge (basics_to_code (transl_cond_notfloat64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpf_bool cmp (rs r1) (rs r2)))) rs'#rd + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros. destruct cmp; simpl. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float.cmp_ne_eq. auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. + rewrite Float.cmp_ne_eq. simpl. destruct (Float.cmp Ceq f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float.cmp Clt f f0); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float.cmp_swap. + destruct (Float.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float.cmp_swap. + destruct (Float.cmp _ _ _); auto. +- econstructor; split. apply exec_straight_one; [simpl; eauto]. + split; intros; Simpl. + unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. + destruct (Float.cmp _ _ _); auto. +Qed. + +Lemma transl_cond_op_correct: + forall cond rd args k c rs m, + transl_cond_op cond rd args k = OK c -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd + /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. +Proof. + assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). + { destruct ob as [[]|]; reflexivity. } + intros until m; intros TR. + destruct cond; simpl in TR; ArgsInv. ++ (* cmp *) + exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpu *) + exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B; eapply Val_cmpu_correct. ++ (* cmpimm *) + apply transl_condimm_int32s_correct; eauto with asmgen. ++ (* cmpuimm *) + apply transl_condimm_int32u_correct; eauto with asmgen. ++ (* cmpl *) + exploit transl_cond_int64s_correct; eauto. simpl. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmplu *) + exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. + eapply Val_cmplu_correct. ++ (* cmplimm *) + exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpluimm *) + exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. + intros (rs' & A & B & C). + exists rs'; repeat split; eauto. rewrite MKTOT; eauto. ++ (* cmpfloat *) + exploit transl_cond_float64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpnosingle *) + exploit transl_cond_nofloat64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpsingle *) + exploit transl_cond_float32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. ++ (* cmpnosingle *) + exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. +Qed. + +(* Translation of arithmetic operations *) + +Ltac SimplEval H := + match type of H with + | Some _ = None _ => discriminate + | Some _ = Some _ => inv H + | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) +end. + +Ltac TranslOpSimpl := + econstructor; split; + [ apply exec_straight_one; reflexivity + | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. + +Lemma int_eq_comm: + forall (x y: int), + (Int.eq x y) = (Int.eq y x). +Proof. + intros. + unfold Int.eq. + unfold zeq. + destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. +Qed. + +Lemma int64_eq_comm: + forall (x y: int64), + (Int64.eq x y) = (Int64.eq y x). +Proof. + intros. + unfold Int64.eq. + unfold zeq. + destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. +Qed. + +Lemma select_same_lessdef: + forall ty c v, + Val.lessdef (Val.select c v v ty) v. +Proof. + intros. + unfold Val.select. + destruct c; try econstructor. + replace (if b then v else v) with v by (destruct b ; trivial). + destruct v; destruct ty; simpl; econstructor. +Qed. + +Lemma if_neg : forall X, + forall a, + forall b c : X, + (if (negb a) then b else c) = (if a then c else b). +Proof. + destruct a; reflexivity. +Qed. + +Lemma int_ltu_to_neq: + forall x, + Int.ltu Int.zero x = negb (Int.eq x Int.zero). +Proof. + intros. + unfold Int.ltu, Int.eq. + change (Int.unsigned Int.zero) with 0. + pose proof (Int.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + +Lemma int64_ltu_to_neq: + forall x, + Int64.ltu Int64.zero x = negb (Int64.eq x Int64.zero). +Proof. + intros. + unfold Int64.ltu, Int64.eq. + change (Int64.unsigned Int64.zero) with 0. + pose proof (Int64.unsigned_range x) as RANGE. + unfold zlt, zeq. + destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. +Qed. + +Ltac splitall := repeat match goal with |- _ /\ _ => split end. + +Lemma transl_op_correct: + forall op args res k (rs: regset) m v c, + transl_op op args res k = OK c -> + eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ Val.lessdef v rs'#(preg_of res) + /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. +Proof. + assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } +Opaque Int.eq. + intros until c; intros TR EV. + unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. +- (* Omove *) + destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. +- (* Oaddrsymbol *) + destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). ++ set (rs1 := (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). + exploit (addptrofs_correct x x ofs (basics_to_code k) rs1 m); eauto with asmgen. + intros (rs2 & A & B & C). + exists rs2; split. + apply exec_straight_step with rs1 m; auto. + split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). + rewrite Genv.shift_symbol_address. + replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). + exact B. + intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. ++ TranslOpSimpl. +- (* Oaddrstack *) + exploit addptrofs_correct. instantiate (1 := SP); auto with asmgen. intros (rs' & A & B & C). + exists rs'; split; eauto. auto with asmgen. +- (* Ocast8signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. + repeat split; intros; simpl; Simpl. + assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Ocast16signed *) + econstructor; split. + eapply exec_straight_two. simpl;eauto. simpl;eauto. + repeat split; intros; Simpl. + assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. + destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. +- (* Oshrximm *) + econstructor; split. + + apply exec_straight_one. simpl. eauto. + + repeat split. + * rewrite Pregmap.gss. + destruct (rs x0); simpl; trivial. + unfold Val.maketotal. + destruct (Int.ltu _ _); simpl; trivial. + * intros. + rewrite Pregmap.gso; trivial. +- (* Oshrxlimm *) + econstructor; split. + + apply exec_straight_one. simpl. eauto. + + repeat split. + * rewrite Pregmap.gss. + destruct (rs x0); simpl; trivial. + unfold Val.maketotal. + destruct (Int.ltu _ _); simpl; trivial. + * intros. + rewrite Pregmap.gso; trivial. + +- (* Ocmp *) + exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). + exists rs'; repeat split; eauto with asmgen. + +- (* Osel *) + unfold conditional_move in *. + destruct (ireg_eq _ _). + { + subst x. inv EQ2. + econstructor; split. + { + apply exec_straight_one. + simpl. reflexivity. + } + split. + { apply select_same_lessdef. } + intros; trivial. + } + + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ2. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x1); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. + +- (* Oselimm *) + unfold conditional_move_imm32 in *. + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. + +- (* Osellimm *) + unfold conditional_move_imm64 in *. + destruct c0; simpl in *. + + all: destruct c. + all: simpl in *. + all: inv EQ0. + all: econstructor; splitall. + all: try apply exec_straight_one. + all: intros; simpl; trivial. + all: unfold Val.select, cmove, cmoveu; simpl. + all: destruct (rs x0); simpl; trivial. + all: try rewrite int_ltu_to_neq. + all: try rewrite int64_ltu_to_neq. + all: try change (Int64.eq Int64.zero Int64.zero) with true. + all: try destruct Archi.ptr64. + all: try rewrite Pregmap.gss. + all: repeat rewrite if_neg. + all: simpl. + all: try destruct (_ || _). + all: try apply Val.lessdef_normalize. + all: trivial. (* no more lessdef *) + all: apply Pregmap.gso; congruence. +Qed. + +(** Memory accesses *) + +Lemma indexed_memory_access_correct: + forall mk_instr base ofs k rs m, + exists base' ofs' rs' ptr', + exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m + (mk_instr base' ofs' ::g k) rs' m + /\ eval_offset ofs' = OK ptr' + /\ Val.offset_ptr rs'#base' ptr' = Val.offset_ptr rs#base ofs + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + unfold indexed_memory_access; intros. + (* destruct Archi.ptr64 eqn:SF. *) + assert (Archi.ptr64 = true) as SF; auto. +- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. + destruct (make_immed64 (Ptrofs.to_int64 ofs)). ++ econstructor; econstructor; econstructor; econstructor; split. + apply exec_straight_opt_refl. + split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. +Qed. + + +Lemma indexed_load_access_correct: + forall trap chunk (mk_instr: ireg -> offset -> basic) rd m, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> + forall (base: ireg) ofs k (rs: regset) v, + Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> + exists rs', + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m + /\ rs'#rd = v + /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until v; intros LOAD. + exploit indexed_memory_access_correct; eauto. + intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. + unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma indexed_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) r1 m, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> + forall (base: ireg) ofs k (rs: regset) m', + Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> + exists rs', + exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros until m; intros EXEC; intros until m'; intros STORE. + exploit indexed_memory_access_correct. (* instantiate (1 := base). eauto. *) + intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. + unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq. rewrite B, C, STORE. + eauto. + discriminate. + auto. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k c (rs: regset) m v, + loadind base ofs ty dst k = OK c -> + Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR LOAD. + assert (A: exists mk_instr rd, + preg_of dst = IR rd + /\ c = indexed_memory_access mk_instr base ofs :: k + /\ forall base' ofs' rs', + exec_basic_instr ge (mk_instr base' ofs') rs' m = + exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs'). + { unfold loadind in TR. + destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } + destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. + eapply indexed_load_access_correct; eauto with asmgen. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k c (rs: regset) m m', + storeind src base ofs ty k = OK c -> + Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros until m'; intros TR STORE. + assert (A: exists mk_instr rr, + preg_of src = IR rr + /\ c = indexed_memory_access mk_instr base ofs :: k + /\ forall base' ofs' rs', + exec_basic_instr ge (mk_instr base' ofs') rs' m = + exec_store_offset (chunk_of_type ty) rs' m rr base' ofs'). + { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; esplit; eauto. } + destruct A as (mk_instr & rr & rsEq & B & C). subst c. + eapply indexed_store_access_correct; eauto with asmgen. + congruence. +Qed. + +Ltac bsimpl := unfold exec_bblock; simpl. + +Lemma Pget_correct: + forall (dst: gpreg) (src: preg) k (rs: regset) m, + src = RA -> + exists rs', + exec_straight ge (Pget dst src ::g k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor. +- rewrite H. bsimpl. auto. +- Simpl. +- intros. Simpl. +Qed. + +Lemma Pset_correct: + forall (dst: preg) (src: gpreg) k (rs: regset) m, + dst = RA -> + exists rs', + exec_straight ge (Pset dst src ::g k) rs m k rs' m + /\ rs'#dst = rs#src + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. econstructor; econstructor; econstructor; simpl. + rewrite H. auto. + Simpl. + Simpl. + intros. rewrite H. Simpl. +Qed. + +Lemma loadind_ptr_correct: + forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, + Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> + exists rs', + exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. +Proof. + intros. eapply indexed_load_access_correct; eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. + instantiate (1 := TRAP). + auto. +Qed. + +Lemma storeind_ptr_correct: + forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', + Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> + exists rs', + exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. + intros. unfold Mptr. assert (Archi.ptr64 = true); auto. +Qed. + +Lemma transl_memory_access_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ofs rs' ptr, + exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m + /\ eval_offset ofs = OK ptr + /\ Val.offset_ptr rs'#base ptr = v + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access in TR; destruct addr; ArgsInv. +- (* indexed *) + inv EV. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). + eexists; eexists; eexists; eexists. split; try split; try split. + eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. + { intros. destruct r; rewrite RSEQ; auto. } +- (* global *) + simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; econstructor; split. + constructor. apply exec_straight_one. simpl; eauto. auto. + split; split; intros; Simpl. + assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). + { apply Val.offset_ptr_zero. } + remember (Genv.symbol_address ge i i0) as symbol. + destruct symbol; auto. + + contradict Heqsymbol; unfold Genv.symbol_address. + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + contradict Heqsymbol; unfold Genv.symbol_address; + destruct (Genv.find_symbol ge i); discriminate. + + simpl. rewrite Ptrofs.add_zero; auto. +- (* stack *) + inv TR. inv EV. + exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). + eexists; eexists; eexists; eexists. split; try split; try split. + eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. + { intros. destruct r; rewrite RSEQ; auto. } +Qed. + +Lemma transl_memory_access2_correct: + forall mk_instr addr args k c (rs: regset) m v, + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + exists base ro mro mr1 rs', + args = mr1 :: mro :: nil + /\ ireg_of mro = OK ro + /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m + /\ Val.addl rs'#base rs'#ro = v + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV. + unfold transl_memory_access2 in TR; destruct addr; ArgsInv. + inv EV. repeat eexists. eassumption. econstructor; eauto. +Qed. + +Lemma transl_memory_access2XS_correct: + forall chunk mk_instr (scale : Z) args k c (rs: regset) m v, + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + exists base ro mro mr1 rs', + args = mr1 :: mro :: nil + /\ ireg_of mro = OK ro + /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m + /\ Val.addl rs'#base (Val.shll rs'#ro (Vint (Int.repr scale))) = v + /\ (forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r) + /\ scale = (zscale_of_chunk chunk). +Proof. + intros until v; intros TR EV. + unfold transl_memory_access2XS in TR; ArgsInv. + inv EV. repeat eexists. eassumption. econstructor; eauto. + symmetry. + apply Z.eqb_eq. + assumption. +Qed. + +Lemma transl_load_access2_correct: + forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = Some v' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma transl_load_access2_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma transl_load_access2XS_correct: + forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = Some v' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + +Lemma transl_load_access2XS_correct_notrap2: + forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro, + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until ro; intros ARGS IREGE INSTR TR EV LOAD. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + +Lemma transl_load_access_correct: + forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = Some v' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = v' + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v'; intros INSTR TR EV LOAD. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split; intros; Simpl. auto. +Qed. + +Lemma transl_load_access_correct_notrap2: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v, + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.loadv chunk m v = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#rd = concrete_default_notrap_load_value chunk + /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. +Proof. + intros until v; intros INSTR TR EV LOAD. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. + split. trivial. intros. Simpl. +Qed. + +Lemma transl_load_memory_access_ok: + forall addr trap chunk args dst k c rs a v m, + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_load trap chunk addr args dst k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists mk_instr rd, + preg_of dst = IR rd + /\ transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs. +Proof. + intros until m. intros ADDR TR ? ?. + unfold transl_load in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. +Qed. + +Lemma transl_load_memory_access_ok_notrap2: + forall addr chunk args dst k c rs a m, + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_load NOTRAP chunk addr args dst k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr rd, + preg_of dst = IR rd + /\ transl_memory_access mk_instr addr args k = OK c + /\ forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs. +Proof. + intros until m. intros ADDR TR ? ?. + unfold transl_load in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. + - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; + [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity + | eauto ]. +Qed. + +Lemma transl_load_memory_access2_ok: + forall trap chunk args dst k c rs a v m, + transl_load trap chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity + | eauto]. +Qed. + + +Lemma transl_load_memory_access2_ok_notrap2: + forall chunk args dst k c rs a m, + transl_load NOTRAP chunk Aindexed2 args dst k = OK c -> + eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity + | eauto]. +Qed. + +Lemma transl_load_memory_access2XS_ok: + forall scale trap chunk args dst k c rs a v m, + transl_load trap chunk (Aindexed2XS scale) args dst k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr scale args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto + | eauto]. +Qed. + + +Lemma transl_load_memory_access2XS_ok_notrap2: + forall scale chunk args dst k c rs a m, + transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists mk_instr mr0 mro rd ro, + args = mr0 :: mro :: nil + /\ preg_of dst = IR rd + /\ preg_of mro = IR ro + /\ transl_memory_access2XS chunk mk_instr scale args k = OK c + /\ forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro. +Proof. + intros until m. intros TR ? ?. + unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity + | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto + | eauto]. +Qed. + +Lemma transl_load_correct: + forall trap chunk addr args dst k c (rs: regset) m a v, + transl_load trap chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until v; intros TR EV LOAD. destruct addr. + - exploit transl_load_memory_access2XS_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access2_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. + - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct; eauto with asmgen. +Qed. + +Lemma transl_load_correct_notrap2: + forall chunk addr args dst k c (rs: regset) m a, + transl_load NOTRAP chunk addr args dst k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.loadv chunk m a = None -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m + /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk) + /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros until a; intros TR EV LOAD. destruct addr. + - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). + rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. + - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). + intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; + eapply transl_load_access_correct_notrap2; eauto with asmgen. +Qed. + +Lemma transl_store_access2_correct: + forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m', + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk rs m r1 base ro) -> + transl_memory_access2 mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. + exploit transl_memory_access2_correct; eauto. + intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_store_reg. unfold parexec_store_reg. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + +Lemma transl_store_access2XS_correct: + forall chunk (mk_instr: ireg -> ireg -> basic) scale args k c r1 (rs: regset) m v mr1 mro ro m', + args = mr1 :: mro :: nil -> + ireg_of mro = OK ro -> + (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_regxs chunk rs m r1 base ro) -> + transl_memory_access2XS chunk mk_instr scale args k = OK c -> + eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> + Mem.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. + exploit transl_memory_access2XS_correct; eauto. + intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. clear ARGS. + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. + rewrite INSTR. unfold exec_store_regxs. unfold parexec_store_regxs. + unfold scale_of_chunk. + subst scale. + rewrite B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + +Lemma transl_store_access_correct: + forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', + (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> + transl_memory_access mk_instr addr args k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> + Mem.storev chunk m v rs#r1 = Some m' -> + r1 <> RTMP -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros INSTR TR EV STORE NOT31. + exploit transl_memory_access_correct; eauto. + intros (base & ofs & rs' & ptr & A & PtrEq & B & C). + econstructor; split. + eapply exec_straight_opt_right. eexact A. apply exec_straight_one. + rewrite INSTR. unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. + intro. inv H. contradiction. + auto. +Qed. + + +Remark exec_store_offset_8_sign rs m x base ofs: + exec_store_offset Mint8unsigned rs m x base ofs = exec_store_offset Mint8signed rs m x base ofs. +Proof. + unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. + destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_offset_16_sign rs m x base ofs: + exec_store_offset Mint16unsigned rs m x base ofs = exec_store_offset Mint16signed rs m x base ofs. +Proof. + unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. + destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + +Lemma transl_store_memory_access_ok: + forall addr chunk args src k c rs a m m', + (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> + transl_store chunk addr args src k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr, + preg_of src = IR rr + /\ transl_memory_access mk_instr addr args k = OK c + /\ (forall base ofs rs, + exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk' rs m rr base ofs) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros ? TR ? ?. + unfold transl_store in TR. destruct addr; try contradiction. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; [ + repeat (destruct args; try discriminate); eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; + [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. + - monadInv TR. destruct chunk. all: + ArgsInv; eexists; eexists; eexists; split; try split; + [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption + | split; eauto; intros; simpl; try reflexivity]. + eapply exec_store_offset_8_sign. + eapply exec_store_offset_16_sign. +Qed. + +Remark exec_store_reg_8_sign rs m x base ofs: + exec_store_reg Mint8unsigned rs m x base ofs = exec_store_reg Mint8signed rs m x base ofs. +Proof. + unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_reg_16_sign rs m x base ofs: + exec_store_reg Mint16unsigned rs m x base ofs = exec_store_reg Mint16signed rs m x base ofs. +Proof. + unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + +Remark exec_store_regxs_8_sign rs m x base ofs: + exec_store_regxs Mint8unsigned rs m x base ofs = exec_store_regxs Mint8signed rs m x base ofs. +Proof. + unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_8. reflexivity. +Qed. + +Remark exec_store_regxs_16_sign rs m x base ofs: + exec_store_regxs Mint16unsigned rs m x base ofs = exec_store_regxs Mint16signed rs m x base ofs. +Proof. + unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. + erewrite <- Mem.store_signed_unsigned_16. reflexivity. +Qed. + +Lemma transl_store_memory_access2_ok: + forall addr chunk args src k c rs a m m', + addr = Aindexed2 -> + transl_store chunk addr args src k = OK c -> + eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr mr0 mro ro, + args = mr0 :: mro :: nil + /\ preg_of mro = IR ro + /\ preg_of src = IR rr + /\ transl_memory_access2 mk_instr addr args k = OK c + /\ (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk' rs m rr base ro) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros ? TR ? ?. + unfold transl_store in TR. subst addr. monadInv TR. destruct chunk. all: + unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ ArgsInv; reflexivity + | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRR _ x)); simpl; reflexivity + | eauto ]. + - simpl. intros. eapply exec_store_reg_8_sign. + - simpl. intros. eapply exec_store_reg_16_sign. +Qed. + +Lemma transl_store_memory_access2XS_ok: + forall scale chunk args src k c rs a m m', + transl_store chunk (Aindexed2XS scale) args src k = OK c -> + eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a (rs (preg_of src)) = Some m' -> + exists mk_instr chunk' rr mr0 mro ro, + args = mr0 :: mro :: nil + /\ preg_of mro = IR ro + /\ preg_of src = IR rr + /\ transl_memory_access2XS chunk' mk_instr scale args k = OK c + /\ (forall base rs, + exec_basic_instr ge (mk_instr base ro) rs m = exec_store_regxs chunk' rs m rr base ro) + /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). +Proof. + intros until m'. intros TR ? ?. + unfold transl_store in TR. monadInv TR. destruct chunk. all: + unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; + [ ArgsInv; reflexivity + | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRRXS _ x)); simpl; rewrite Heqb; eauto + | eauto ]. + - simpl. intros. eapply exec_store_regxs_8_sign. + - simpl. intros. eapply exec_store_regxs_16_sign. +Qed. + +Lemma transl_store_correct: + forall chunk addr args src k c (rs: regset) m a m', + transl_store chunk addr args src k = OK c -> + eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> + Mem.storev chunk m a rs#(preg_of src) = Some m' -> + exists rs', + exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' + /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. +Proof. + intros until m'; intros TR EV STORE. destruct addr. + - exploit transl_store_memory_access2XS_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). + eapply transl_store_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. + destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. + - exploit transl_store_memory_access2_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). + eapply transl_store_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. + destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. + - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). + intro A; + destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); + rewrite D in STORE; clear D; + eapply transl_store_access_correct; eauto with asmgen; try congruence; + destruct rr; try discriminate; destruct src; try discriminate. +Qed. + +Lemma make_epilogue_correct: + forall ge0 f m stk soff cs m' ms rs k tm, + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> + Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + agree ms (Vptr stk soff) rs -> + Mem.extends m tm -> + match_stack ge0 cs -> + exists rs', exists tm', + exec_straight ge (make_epilogue f k) rs tm k rs' tm' + /\ agree ms (parent_sp cs) rs' + /\ Mem.extends m' tm' + /\ rs'#RA = parent_ra cs + /\ rs'#SP = parent_sp cs + /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> RTMP -> r <> GPRA -> rs'#r = rs#r). +Proof. + intros until tm; intros LP LRA FREE AG MEXT MCS. + exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). + exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). + exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. + exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. + exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). + unfold make_epilogue. + rewrite chunk_of_Tptr in *. + + exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPRA (Pset RA GPRA ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) + rs tm). + - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. + - intros (rs1 & A1 & B1 & C1). + assert (agree ms (Vptr stk soff) rs1) as AG1. + + destruct AG. + apply mkagree; auto. + rewrite C1; discriminate || auto. + intro. rewrite C1; auto; destruct r; simpl; try discriminate. + + exploit (Pset_correct RA GPRA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. + intros (rs2 & A2 & B2 & C2). + econstructor; econstructor; split. + * eapply exec_straight_trans. + { eexact A1. } + { eapply exec_straight_trans. + { eapply A2. } + { apply exec_straight_one. simpl. + rewrite (C2 SP) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. + rewrite FREE'. eauto. } } + * split. apply agree_set_other; auto with asmgen. + apply agree_change_sp with (Vptr stk soff). + apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. + eapply parent_sp_def; eauto. + split. auto. + split. Simpl. rewrite B2. auto. + split. Simpl. + intros. Simpl. + rewrite C2; auto. +Qed. + +End CONSTRUCTORS. + + diff --git a/kvx/Asmblockprops.v b/kvx/Asmblockprops.v new file mode 100644 index 00000000..bc14b231 --- /dev/null +++ b/kvx/Asmblockprops.v @@ -0,0 +1,357 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Common definition and proofs on Asmblock required by various modules *) + +Require Import Coqlib. +Require Import Integers. +Require Import Memory. +Require Import Globalenvs. +Require Import Values. +Require Import Asmblock. +Require Import Axioms. + +Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := + forall rs m, + exec_bblock ge f bb rs m <> Stuck -> + exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. + +Hint Extern 2 (_ <> _) => congruence: asmgen. + +Lemma preg_of_data: + forall r, data_preg (preg_of r) = true. +Proof. + intros. destruct r; reflexivity. +Qed. +Hint Resolve preg_of_data: asmgen. + +Lemma data_diff: + forall r r', + data_preg r = true -> data_preg r' = false -> r <> r'. +Proof. + congruence. +Qed. +Hint Resolve data_diff: asmgen. + +Lemma preg_of_not_PC: + forall r, preg_of r <> PC. +Proof. + intros. apply data_diff; auto with asmgen. +Qed. + +Lemma preg_of_not_SP: + forall r, preg_of r <> SP. +Proof. + intros. unfold preg_of; destruct r; simpl; congruence. +Qed. + +Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. + + +Lemma nextblock_pc: + forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). +Proof. + intros. apply Pregmap.gss. +Qed. + +Lemma nextblock_inv: + forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. +Proof. + intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. +Qed. + +Lemma nextblock_inv1: + forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. +Proof. + intros. apply nextblock_inv. red; intro; subst; discriminate. +Qed. + +Ltac Simplif := + ((rewrite nextblock_inv by eauto with asmgen) + || (rewrite nextblock_inv1 by eauto with asmgen) + || (rewrite Pregmap.gss) + || (rewrite nextblock_pc) + || (rewrite Pregmap.gso by eauto with asmgen) + ); auto with asmgen. + +Ltac Simpl := repeat Simplif. + +(* For Asmblockgenproof0 *) + +Theorem exec_basic_instr_pc: + forall ge b rs1 m1 rs2 m2, + exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + intros. destruct b; try destruct i; try destruct i. + all: try (inv H; Simpl). + 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. + + { (* PLoadQRRO *) + unfold parexec_load_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + { (* PLoadORRO *) + unfold parexec_load_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + destruct (Mem.loadv _ _ _) in H1; try discriminate. + inv H1. Simpl. } + 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. + 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. + + { (* PStoreQRRO *) + unfold parexec_store_q_offset in H1. + destruct (gpreg_q_expand _) as [r0 r1] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + { (* PStoreORRO *) + unfold parexec_store_o_offset in H1. + destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. + unfold eval_offset in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + destruct (Mem.storev _ _ _) in H1; try discriminate. + inv H1. Simpl. reflexivity. } + - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. + - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. + destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. + - destruct rs; try discriminate. inv H1. Simpl. + - destruct rd; try discriminate. inv H1; Simpl. + - reflexivity. +Qed. + +(* For PostpassSchedulingproof *) + +Lemma regset_double_set: + forall r1 r2 (rs: regset) v1 v2, + r1 <> r2 -> + (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). +Proof. + intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). + - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. + - destruct (preg_eq r r2). + + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. + + repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma next_eq: + forall (rs rs': regset) m m', + rs = rs' -> m = m' -> Next rs m = Next rs' m'. +Proof. + intros; apply f_equal2; auto. +Qed. + +Lemma exec_load_offset_pc_var: + forall trap t rs m rd ra ofs rs' m' v, + exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> + exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_reg_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_reg trap t rs m rd ra ro = Next rs' m' -> + exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_regxs_pc_var: + forall trap t rs m rd ra ro rs' m' v, + exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> + exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _). + - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. + - unfold parexec_incorrect_load in *. + destruct trap; try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. +Qed. + +Lemma exec_load_offset_q_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_q_offset rs m rd ra ofs = Next rs' m' -> + exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. + destruct (gpreg_q_expand rd) as [rd0 rd1]. + (* destruct (ireg_eq rd0 ra); try discriminate. *) + rewrite Pregmap.gso; try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + inv H. + destruct (Mem.loadv _ _ _); try discriminate. + inv H1. f_equal. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + reflexivity. +Qed. + +Lemma exec_load_offset_o_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_load_o_offset rs m rd ra ofs = Next rs' m' -> + exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. + destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. +(* + destruct (ireg_eq rd0 ra); try discriminate. + destruct (ireg_eq rd1 ra); try discriminate. + destruct (ireg_eq rd2 ra); try discriminate. +*) + rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + destruct (Mem.loadv _ _ _); try discriminate. + rewrite (regset_double_set PC rd0) by discriminate. + rewrite (regset_double_set PC rd1) by discriminate. + rewrite (regset_double_set PC rd2) by discriminate. + rewrite (regset_double_set PC rd3) by discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_offset_pc_var: + forall t rs m rd ra ofs rs' m' v, + exec_store_offset t rs m rd ra ofs = Next rs' m' -> + exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. + destruct (eval_offset ofs); try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_q_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_q_offset rs m rd ra ofs = Next rs' m' -> + exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. + simpl in *. + destruct (gpreg_q_expand _) as [s0 s1]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. apply next_eq; auto. +Qed. + +Lemma exec_store_o_offset_pc_var: + forall rs m rd ra ofs rs' m' v, + exec_store_o_offset rs m rd ra ofs = Next rs' m' -> + exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. +Proof. + intros. + unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. + destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + destruct (Mem.storev _ _ _); try discriminate. + inv H. + trivial. +Qed. + +Lemma exec_store_reg_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_reg t rs m rd ra ro = Next rs' m' -> + exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Lemma exec_store_regxs_pc_var: + forall t rs m rd ra ro rs' m' v, + exec_store_regxs t rs m rd ra ro = Next rs' m' -> + exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. +Proof. + intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. + destruct (Mem.storev _ _ _). + - inv H. apply next_eq; auto. + - discriminate. +Qed. + +Theorem exec_basic_instr_pc_var: + forall ge i rs m rs' m' v, + exec_basic_instr ge i rs m = Next rs' m' -> + exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. + - unfold exec_arith_instr in *. destruct i; destruct i. + all: try (exploreInst; inv H; apply next_eq; auto; + apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). +(* + (* Some cases treated seperately because exploreInst destructs too much *) + all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) + - destruct i. + + exploreInst; apply exec_load_offset_pc_var; auto. + + exploreInst; apply exec_load_reg_pc_var; auto. + + exploreInst; apply exec_load_regxs_pc_var; auto. + + apply exec_load_offset_q_pc_var; auto. + + apply exec_load_offset_o_pc_var; auto. + - destruct i. + + exploreInst; apply exec_store_offset_pc_var; auto. + + exploreInst; apply exec_store_reg_pc_var; auto. + + exploreInst; apply exec_store_regxs_pc_var; auto. + + apply exec_store_q_offset_pc_var; auto. + + apply exec_store_o_offset_pc_var; auto. + - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.storev _ _ _ _); try discriminate. + inv H. apply next_eq; auto. apply functional_extensionality. intros. + rewrite (regset_double_set GPR32 PC); try discriminate. + rewrite (regset_double_set GPR12 PC); try discriminate. + rewrite (regset_double_set FP PC); try discriminate. reflexivity. + - repeat (rewrite Pregmap.gso; try discriminate). + destruct (Mem.loadv _ _ _); try discriminate. + destruct (rs GPR12); try discriminate. + destruct (Mem.free _ _ _ _); try discriminate. + inv H. apply next_eq; auto. + rewrite (regset_double_set GPR32 PC). + rewrite (regset_double_set GPR12 PC). reflexivity. + all: discriminate. + - destruct rs0; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - destruct rd; try discriminate. inv H. apply next_eq; auto. + repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. + - inv H. apply next_eq; auto. +Qed. + + diff --git a/kvx/Asmexpand.ml b/kvx/Asmexpand.ml new file mode 100644 index 00000000..5d4fd2f5 --- /dev/null +++ b/kvx/Asmexpand.ml @@ -0,0 +1,636 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(* Expanding built-ins and some pseudo-instructions by rewriting + of the RISC-V assembly code. *) + +open Asm +open Asmexpandaux +open AST +open Camlcoq + +exception Error of string + +(* Useful constants and helper functions *) + +let _0 = Integers.Int.zero +let _1 = Integers.Int.one +let _2 = coqint_of_camlint 2l +let _4 = coqint_of_camlint 4l +let _8 = coqint_of_camlint 8l +let _16 = coqint_of_camlint 16l +let _m1 = coqint_of_camlint (-1l) + +let wordsize = if Archi.ptr64 then 8 else 4 + +let align n a = (n + a - 1) land (-a) + +let stack_pointer = Asmvliw.GPR12 + +(* Emit instruction sequences that set or offset a register by a constant. *) +(* + let expand_loadimm32 dst n = + List.iter emit (Asmgen.loadimm32 dst n []) +*) +let expand_addptrofs dst src n = + List.iter emit (basic_to_instruction (Asmvliw.PArith (Asmblockgen.addptrofs dst src n)) :: []) +let expand_storeind_ptr src base ofs = + List.iter emit (basic_to_instruction (Asmblockgen.storeind_ptr src base ofs) :: []) +let expand_loadind_ptr dst base ofs = + List.iter emit (basic_to_instruction (Asmblockgen.loadind_ptr base ofs dst) :: []) + +(* Built-ins. They come in two flavors: + - annotation statements: take their arguments in registers or stack + locations; generate no code; + - inlined by the compiler: take their arguments in arbitrary + registers. +*) + +(* Fix-up code around calls to variadic functions. Floating-point arguments + residing in FP registers need to be moved to integer registers. *) + +let int_param_regs = let open Asmvliw in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11 |] +(* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) +let float_param_regs = [| |] + +let fixup_variadic_call pos tyl = assert false +(*if pos < 8 then + match tyl with + | [] -> + () + | (Tint | Tany32) :: tyl -> + fixup_variadic_call (pos + 1) tyl + | Tsingle :: tyl -> + let rs =float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxs(rd, rs)); + fixup_variadic_call (pos + 1) tyl + | Tlong :: tyl -> + let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in + fixup_variadic_call pos' tyl + | (Tfloat | Tany64) :: tyl -> + if Archi.ptr64 then begin + let rs = float_param_regs.(pos) + and rd = int_param_regs.(pos) in + emit (Pfmvxd(rd, rs)); + fixup_variadic_call (pos + 1) tyl + end else begin + let pos = align pos 2 in + if pos < 8 then begin + let rs = float_param_regs.(pos) + and rd1 = int_param_regs.(pos) + and rd2 = int_param_regs.(pos + 1) in + emit (Paddiw(X2, X X2, Integers.Int.neg _16)); + emit (Pfsd(rs, X2, Ofsimm _0)); + emit (Plw(rd1, X2, Ofsimm _0)); + emit (Plw(rd2, X2, Ofsimm _4)); + emit (Paddiw(X2, X X2, _16)); + fixup_variadic_call (pos + 2) tyl + end + end +*) + +let fixup_call sg = + if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args + +(* Handling of annotations *) + +let expand_annot_val kind txt targ args res = + emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); + match args, res with + | [BA(Asmvliw.IR src)], BR(Asmvliw.IR dst) -> + if dst <> src then emit (Pmv (dst, src)) + | _, _ -> + raise (Error "ill-formed __builtin_annot_val") + +(* Handling of memcpy *) + +let emit_move dst r = + if dst <> r + then emit (Paddil(dst, r, Z.zero));; + +(* FIXME DMonniaux this is probably not complete *) +let get_builtin_arg dst arg = + match arg with + | BA (Asmvliw.IR reg) -> emit_move dst reg + | BA (ireg) -> failwith "get_builtin_arg: BA_int(not ireg)" + | BA_int _ -> failwith "get_builtin_arg: BA_int" + | BA_long _ -> failwith "get_builtin_arg: BA_long" + | BA_float _ -> failwith "get_builtin_arg: BA_float" + | BA_single _ -> failwith "get_builtin_arg: BA_single" + | BA_loadstack _ -> failwith "get_builtin_arg: BA_loadstack" + | BA_addrstack ofs -> emit (Paddil(dst, stack_pointer, ofs)) + | BA_loadglobal _ -> failwith "get_builtin_arg: BA_loadglobal" + | BA_addrglobal _ -> failwith "get_builtin_arg: BA_addrglobal" + | BA_splitlong _ -> failwith "get_builtin_arg: BA_splitlong" + | BA_addptr _ -> failwith "get_builtin_arg: BA_addptr";; + +let smart_memcpy = true + +(* FIXME DMonniaux this is really suboptimal (byte per byte) *) +let expand_builtin_memcpy_big sz al src dst = + assert (sz > Z.zero); + let dstptr = Asmvliw.GPR62 + and srcptr = Asmvliw.GPR63 + and tmpbuf = Asmvliw.GPR61 + and tmpbuf2 = Asmvliw.R60R61 + and caml_sz = camlint64_of_coqint sz in + get_builtin_arg dstptr dst; + get_builtin_arg srcptr src; + let caml_sz_div16 = Int64.shift_right caml_sz 4 + and sixteen = coqint_of_camlint64 16L in + if smart_memcpy + then + let remaining = ref caml_sz + and offset = ref 0L in + let cpy buf size load store = + (if !remaining >= size + then + let zofs = coqint_of_camlint64 !offset in + begin + emit Psemi; + emit (load buf srcptr (AOff zofs)); + emit Psemi; + emit (store buf dstptr (AOff zofs)); + remaining := Int64.sub !remaining size; + offset := Int64.add !offset size + end) in + begin + (if caml_sz_div16 >= 2L + then + begin + emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div16))); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Plq (tmpbuf2, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, sixteen)); + emit Psemi; + emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, sixteen)); + emit Psemi; + emit (Plabel lbl); + remaining := Int64.sub !remaining (Int64.shift_left caml_sz_div16 4) + end); + + cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z)); + cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z)); + cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z)); + cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z)); + cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z)); + assert (!remaining = 0L) + end + else + begin + emit (Pmake (tmpbuf, sz)); + emit Psemi; + let lbl = new_label() in + emit (Ploopdo (tmpbuf, lbl)); + emit Psemi; + emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero)); + emit (Paddil (srcptr, srcptr, Z.one)); + emit Psemi; + emit (Psb (tmpbuf, dstptr, AOff Z.zero)); + emit (Paddil (dstptr, dstptr, Z.one)); + emit Psemi; + emit (Plabel lbl); + end;; + +let expand_builtin_memcpy sz al args = + match args with + | [dst; src] -> + expand_builtin_memcpy_big sz al src dst + | _ -> assert false;; + +(* Handling of volatile reads and writes *) +(* FIXME probably need to check for size of displacement *) +let expand_builtin_vload_common chunk base ofs res = + match chunk, res with + | Mint8unsigned, BR(Asmvliw.IR res) -> + emit (Plbu (TRAP, res, base, AOff ofs)) + | Mint8signed, BR(Asmvliw.IR res) -> + emit (Plb (TRAP, res, base, AOff ofs)) + | Mint16unsigned, BR(Asmvliw.IR res) -> + emit (Plhu (TRAP, res, base, AOff ofs)) + | Mint16signed, BR(Asmvliw.IR res) -> + emit (Plh (TRAP, res, base, AOff ofs)) + | Mint32, BR(Asmvliw.IR res) -> + emit (Plw (TRAP, res, base, AOff ofs)) + | Mint64, BR(Asmvliw.IR res) -> + emit (Pld (TRAP, res, base, AOff ofs)) + | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> + let ofs' = Integers.Ptrofs.add ofs _4 in + if base <> res2 then begin + emit (Plw (TRAP, res2, base, AOff ofs)); + emit (Plw (TRAP, res1, base, AOff ofs')) + end else begin + emit (Plw (TRAP, res1, base, AOff ofs')); + emit (Plw (TRAP, res2, base, AOff ofs)) + end + | Mfloat32, BR(Asmvliw.IR res) -> + emit (Pfls (TRAP, res, base, AOff ofs)) + | Mfloat64, BR(Asmvliw.IR res) -> + emit (Pfld (TRAP, res, base, AOff ofs)) + | _ -> + assert false + +let expand_builtin_vload chunk args res = + match args with + | [BA(Asmvliw.IR addr)] -> + expand_builtin_vload_common chunk addr _0 res + | [BA_addrstack ofs] -> + expand_builtin_vload_common chunk stack_pointer ofs res + | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs))] -> + expand_builtin_vload_common chunk addr ofs res + | _ -> + assert false + + +let expand_builtin_vstore_common chunk base ofs src = + match chunk, src with + | (Mint8signed | Mint8unsigned), BA(Asmvliw.IR src) -> + emit (Psb (src, base, AOff ofs)) + | (Mint16signed | Mint16unsigned), BA(Asmvliw.IR src) -> + emit (Psh (src, base, AOff ofs)) + | Mint32, BA(Asmvliw.IR src) -> + emit (Psw (src, base, AOff ofs)) + | Mint64, BA(Asmvliw.IR src) -> + emit (Psd (src, base, AOff ofs)) + | Mint64, BA_splitlong(BA(Asmvliw.IR src1), BA(Asmvliw.IR src2)) -> + let ofs' = Integers.Ptrofs.add ofs _4 in + emit (Psw (src2, base, AOff ofs)); + emit (Psw (src1, base, AOff ofs')) + | Mfloat32, BA(Asmvliw.IR src) -> + emit (Pfss (src, base, AOff ofs)) + | Mfloat64, BA(Asmvliw.IR src) -> + emit (Pfsd (src, base, AOff ofs)) + | _ -> + assert false + +let expand_builtin_vstore chunk args = + match args with + | [BA(Asmvliw.IR addr); src] -> + expand_builtin_vstore_common chunk addr _0 src + | [BA_addrstack ofs; src] -> + expand_builtin_vstore_common chunk stack_pointer ofs src + | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs)); src] -> + expand_builtin_vstore_common chunk addr ofs src + | _ -> + assert false + +(* Handling of varargs *) + +(* Size in words of the arguments to a function. This includes both + arguments passed in registers and arguments passed on stack. *) + +let rec args_size sz = function + | [] -> sz + | (Tint | Tsingle | Tany32) :: l -> + args_size (sz + 1) l + | (Tlong | Tfloat | Tany64) :: l -> + args_size (if Archi.ptr64 then sz + 1 else align sz 2 + 2) l + +let arguments_size sg = + args_size 0 sg.sig_args + +let _nbregargs_ = 12 +let _alignment_ = 8 + +let save_arguments first_reg base_ofs = let open Asmvliw in + for i = first_reg to (_nbregargs_ - 1) do begin + expand_storeind_ptr + int_param_regs.(i) + GPR12 + (Integers.Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))); + emit Psemi + end done + +let vararg_start_ofs : Z.t option ref = ref None + +let expand_builtin_va_start r = (* assert false *) +match !vararg_start_ofs with + | None -> + invalid_arg "Fatal error: va_start used in non-vararg function" + | Some ofs -> + expand_addptrofs Asmvliw.GPR32 stack_pointer (Integers.Ptrofs.repr ofs); + emit Psemi; + expand_storeind_ptr Asmvliw.GPR32 r Integers.Ptrofs.zero + +(* Auxiliary for 64-bit integer arithmetic built-ins. They expand to + two instructions, one computing the low 32 bits of the result, + followed by another computing the high 32 bits. In cases where + the first instruction would overwrite arguments to the second + instruction, we must go through X31 to hold the low 32 bits of the result. +*) + +let expand_int64_arith conflict rl fn = assert false +(*if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl *) + +(* Byte swaps. There are no specific instructions, so we use standard, + not-very-efficient formulas. *) + +let expand_bswap16 d s = let open Asmvliw in + (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) + emit (Pandiw(GPR32, s, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Psrliw(d, s, _8)); emit Psemi; + emit (Pandiw(d, d, coqint_of_camlint 0xFFl)); + emit (Porw(d, GPR32, d)); emit Psemi + +let expand_bswap32 d s = let open Asmvliw in + (* d = (s << 24) + | (((s >> 8) & 0xFF) << 16) + | (((s >> 16) & 0xFF) << 8) + | (s >> 24) *) + emit (Pslliw(GPR16, s, coqint_of_camlint 24l)); emit Psemi; + emit (Psrliw(GPR32, s, _8)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _16)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR31)); emit Psemi; + emit (Psrliw(GPR32, s, _16)); emit Psemi; + emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; + emit (Porw(GPR16, GPR16, GPR32)); emit Psemi; + emit (Psrliw(GPR32, s, coqint_of_camlint 24l)); emit Psemi; + emit (Porw(d, GPR16, GPR32)); emit Psemi + +let expand_bswap64 d s = let open Asmvliw in + (* d = s << 56 + | (((s >> 8) & 0xFF) << 48) + | (((s >> 16) & 0xFF) << 40) + | (((s >> 24) & 0xFF) << 32) + | (((s >> 32) & 0xFF) << 24) + | (((s >> 40) & 0xFF) << 16) + | (((s >> 48) & 0xFF) << 8) + | s >> 56 *) + emit (Psllil(GPR16, s, coqint_of_camlint 56l)); emit Psemi; + List.iter + (fun (n1, n2) -> + emit (Psrlil(GPR32, s, coqint_of_camlint n1)); emit Psemi; + emit (Pandil(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; + emit (Psllil(GPR32, GPR32, coqint_of_camlint n2)); emit Psemi; + emit (Porl(GPR16, GPR16, GPR32)); emit Psemi;) + [(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)]; + emit (Psrlil(GPR32, s, coqint_of_camlint 56l)); emit Psemi; + emit (Porl(d, GPR16, GPR32)); emit Psemi + +(* Handling of compiler-inlined builtins *) +let last_system_register = 511l +let not_system_register cn =cn<0l || cn>last_system_register + +let expand_builtin_inline name args res = let open Asmvliw in + match name, args, res with + (* Synchronization *) + | "__builtin_membar", [], _ -> + () + (* Vararg stuff *) + | "__builtin_va_start", [BA(IR a)], _ -> + expand_builtin_va_start a + | "__builtin_clzll", [BA(IR a)], BR(IR res) -> + emit (Pclzll(res, a)) + | "__builtin_kvx_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> + emit (Pstsud(res, a1, a2)) + | "__builtin_kvx_get", [BA_int(n)], BR(IR res) -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_kvx_get(n): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pgetn(n, res))) + | "__builtin_kvx_set", [BA_int(n); BA(IR src)], _ -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_kvx_set(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Psetn(n, src))) + | "__builtin_kvx_wfxl", [BA_int(n); BA(IR src)], _ -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_kvx_wfxl(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pwfxl(n, src))) + | "__builtin_kvx_wfxm", [BA_int(n); BA(IR src)], _ -> + let cn = camlint_of_coqint n in + (if not_system_register cn + then failwith (Printf.sprintf "__builtin_kvx_wfxm(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) + else emit (Pwfxm(n, src))) + | "__builtin_kvx_ldu", [BA(IR addr)], BR(IR res) -> + emit (Pldu(res, addr)) + | "__builtin_kvx_lbzu", [BA(IR addr)], BR(IR res) -> + emit (Plbzu(res, addr)) + | "__builtin_kvx_lhzu", [BA(IR addr)], BR(IR res) -> + emit (Plhzu(res, addr)) + | "__builtin_kvx_lwzu", [BA(IR addr)], BR(IR res) -> + emit (Plwzu(res, addr)) + | "__builtin_kvx_alclrd", [BA(IR addr)], BR(IR res) -> + emit (Palclrd(res, addr)) + | "__builtin_kvx_alclrw", [BA(IR addr)], BR(IR res) -> + emit (Palclrw(res, addr)) + | "__builtin_kvx_await", [], _ -> + emit Pawait + | "__builtin_kvx_sleep", [], _ -> + emit Psleep + | "__builtin_kvx_stop", [], _ -> + emit Pstop + | "__builtin_kvx_barrier", [], _ -> + emit Pbarrier + | "__builtin_kvx_fence", [], _ -> + emit Pfence + | "__builtin_kvx_dinval", [], _ -> + emit Pdinval + | "__builtin_kvx_dinvall", [BA(IR addr)], _ -> + emit (Pdinvall addr) + | "__builtin_kvx_dtouchl", [BA(IR addr)], _ -> + emit (Pdtouchl addr) + | "__builtin_kvx_iinval", [], _ -> + emit Piinval + | "__builtin_kvx_iinvals", [BA(IR addr)], _ -> + emit (Piinvals addr) + | "__builtin_kvx_itouchl", [BA(IR addr)], _ -> + emit (Pitouchl addr) + | "__builtin_kvx_dzerol", [BA(IR addr)], _ -> + emit (Pdzerol addr) +(*| "__builtin_kvx_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> + (if res <> incr_res + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); + emit (Pafaddd(addr, res)) + | "__builtin_kvx_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> + (if res <> incr_res + then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); + emit (Pafaddw(addr, res)) *) (* see #157 *) + | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> + emit (Palclrd(res, addr)) + | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> + emit (Palclrw(res, addr)) + | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + expand_bswap16 res a1 + | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> + expand_bswap32 res a1 + | "__builtin_bswap64", [BA(IR src)], BR(IR res) -> + expand_bswap64 res src + + (* Byte swaps *) +(*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> + expand_bswap16 res a1 + | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> + emit (Pfabsd(res, a1)) +*) + (* Catch-all *) + | _ -> + raise (Error ("unrecognized builtin " ^ name)) + +(* Expansion of instructions *) + +let expand_instruction instr = + match instr with + | Pallocframe (sz, ofs) -> + let sg = get_current_function_sig() in + emit (Pmv (Asmvliw.GPR17, stack_pointer)); + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in + let full_sz = Z.add sz (Z.of_uint extra_sz) in + expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.neg full_sz)); + emit Psemi; + expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; + emit Psemi; + let va_ofs = + let extra_ofs = if n <= _nbregargs_ then 0 else ((n - _nbregargs_) * wordsize) in + Z.add sz (Z.of_sint extra_ofs) in + vararg_start_ofs := Some va_ofs; + save_arguments n va_ofs + end else begin + let below = Integers.Ptrofs.repr (Z.neg sz) in + expand_addptrofs stack_pointer stack_pointer below; + emit Psemi; (* Psemi required to fit in resource constraints *) + expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below); + vararg_start_ofs := None + end + | Pfreeframe (sz, ofs) -> + let sg = get_current_function_sig() in + let extra_sz = + if sg.sig_cc.cc_vararg then begin + let n = arguments_size sg in + if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) + end else 0 in + expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) + +(*| Pseqw(rd, rs1, rs2) -> + (* emulate based on the fact that x == 0 iff x + (* emulate based on the fact that x != 0 iff 0 + (* emulate based on the fact that x == 0 iff x + (* emulate based on the fact that x != 0 iff 0 + assert Archi.ptr64; + emit (Paddiw (rd, rs, Integers.Int.zero)) (* 32-bit sign extension *) + +(*| Pjal_r(r, sg) -> + fixup_call sg; emit instr + | Pjal_s(symb, sg) -> + fixup_call sg; emit instr + | Pj_r(r, sg) when r <> X1 -> + fixup_call sg; emit instr + | Pj_s(symb, sg) -> + fixup_call sg; emit instr + +*)| Pbuiltin (ef,args,res) -> + begin match ef with + | EF_builtin (name,sg) -> + expand_builtin_inline (camlstring_of_coqstring name) args res + | EF_vload chunk -> + expand_builtin_vload chunk args res + | EF_vstore chunk -> + expand_builtin_vstore chunk args +(* | EF_annot_val (kind,txt,targ) -> + expand_annot_val kind txt targ args res *) + | EF_memcpy(sz, al) -> + expand_builtin_memcpy sz al args + (* | EF_annot _ | EF_debug _ | EF_inline_asm _ -> + emit instr + *) + | EF_malloc -> failwith "asmexpand: malloc" + | EF_free -> failwith "asmexpand: free" + | EF_debug _ -> failwith "asmexpand: debug" + | EF_annot _ -> emit instr + | EF_annot_val (kind, txt, targ) -> expand_annot_val kind txt targ args res + | EF_external _ -> failwith "asmexpand: external" + | EF_inline_asm _ -> emit instr + | EF_runtime _ -> failwith "asmexpand: runtime" + | EF_profiling _ -> emit instr + end + | _ -> + emit instr + +(* NOTE: Dwarf register maps for RV32G are not yet specified + officially. This is just a placeholder. *) +let int_reg_to_dwarf = let open Asmvliw in function + | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 + | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 + | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 + | GPR15 -> 16 | GPR16 -> 17 | GPR17 -> 18 | GPR18 -> 19 | GPR19 -> 20 + | GPR20 -> 21 | GPR21 -> 22 | GPR22 -> 23 | GPR23 -> 24 | GPR24 -> 25 + | GPR25 -> 26 | GPR26 -> 27 | GPR27 -> 28 | GPR28 -> 29 | GPR29 -> 30 + | GPR30 -> 31 | GPR31 -> 32 | GPR32 -> 33 | GPR33 -> 34 | GPR34 -> 35 + | GPR35 -> 36 | GPR36 -> 37 | GPR37 -> 38 | GPR38 -> 39 | GPR39 -> 40 + | GPR40 -> 41 | GPR41 -> 42 | GPR42 -> 43 | GPR43 -> 44 | GPR44 -> 45 + | GPR45 -> 46 | GPR46 -> 47 | GPR47 -> 48 | GPR48 -> 49 | GPR49 -> 50 + | GPR50 -> 51 | GPR51 -> 52 | GPR52 -> 53 | GPR53 -> 54 | GPR54 -> 55 + | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 + | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 + +let preg_to_dwarf = let open Asmvliw in function + | IR r -> int_reg_to_dwarf r + | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) + | _ -> assert false + +let expand_function id fn = + try + set_current_function fn; + expand id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code; + Errors.OK (get_current_function ()) + with Error s -> + Errors.Error (Errors.msg (coqstring_of_camlstring s)) + +let expand_fundef id = function + | Internal f -> + begin match expand_function id f with + | Errors.OK tf -> Errors.OK (Internal tf) + | Errors.Error msg -> Errors.Error msg + end + | External ef -> + Errors.OK (External ef) + +let expand_program (p: Asm.program) : Asm.program Errors.res = + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/kvx/Asmgen.v b/kvx/Asmgen.v new file mode 100644 index 00000000..61856acf --- /dev/null +++ b/kvx/Asmgen.v @@ -0,0 +1,41 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Integers. +Require Import Mach Asm Asmblock Asmblockgen Machblockgen. +Require Import PostpassScheduling. +Require Import Errors String. +Require Compopts. + +Local Open Scope error_monad_scope. + +Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f. + +Definition transf_program (p: Mach.program) : res Asm.program := + let mbp := (time "Machblock generation" Machblockgen.transf_program) p in + do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; + do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp; + OK ((time "Asm generation" Asm.transf_program) abp'). + +Definition transf_function (f: Mach.function) : res Asm.function := + let mbf := Machblockgen.transf_function f in + do abf <- Asmblockgen.transf_function mbf; + OK (Asm.transf_function abf). + +Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) := + let mbf := Machblockgen.transf_function f in + let mbc := Machblockgen.trans_code l in + do abc <- transl_blocks mbf mbc true; + OK (unfold abc). diff --git a/kvx/Asmgenproof.v b/kvx/Asmgenproof.v new file mode 100644 index 00000000..f43acd37 --- /dev/null +++ b/kvx/Asmgenproof.v @@ -0,0 +1,95 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Correctness proof for Asmgen *) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. +Require Import Machblockgenproof Asmblockgenproof PostpassSchedulingproof. + +Local Open Scope linking_scope. + +Definition block_passes := + mkpass Machblockgenproof.match_prog + ::: mkpass Asmblockgenproof.match_prog + ::: mkpass PostpassSchedulingproof.match_prog + ::: mkpass Asm.match_prog + ::: pass_nil _. + +Definition match_prog := pass_match (compose_passes block_passes). + +Lemma transf_program_match: + forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. +Proof. + intros p tp H. + unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. + inversion_clear H. apply bind_inversion in H1. destruct H1. + inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. + unfold match_prog; simpl. + exists mbp; split. apply Machblockgenproof.transf_program_match; auto. + exists x; split. apply Asmblockgenproof.transf_program_match; auto. + exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. + exists tp; split. apply Asm.transf_program_match; auto. auto. +Qed. + +(** Return Address Offset *) + +Definition return_address_offset: Mach.function -> Mach.code -> ptrofs -> Prop := + Mach_return_address_offset Asmblockgenproof.return_address_offset. + +Lemma return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros; unfold return_address_offset; eapply Mach_return_address_exists; eauto. + intros; eapply Asmblockgenproof.return_address_exists; eauto. +Qed. + + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). +Proof. + unfold match_prog in TRANSF. simpl in TRANSF. + inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. + eapply compose_forward_simulations. + exploit Machblockgenproof.transf_program_correct; eauto. + unfold Machblockgenproof.inv_trans_rao. + eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. + eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. + apply Asm.transf_program_correct. eauto. +Qed. + +End PRESERVATION. + +Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). + +(*******************************************) +(* Stub actually needed by driver/Compiler *) + +Module Asmgenproof0. + +Definition return_address_offset := return_address_offset. + +End Asmgenproof0. diff --git a/kvx/Asmvliw.v b/kvx/Asmvliw.v new file mode 100644 index 00000000..301ee69a --- /dev/null +++ b/kvx/Asmvliw.v @@ -0,0 +1,1812 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Abstract syntax and semantics for VLIW semantics of KVX assembly language. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Locations. +Require Stacklayout. +Require Import Conventions. +Require Import Errors. +Require Import Sorting.Permutation. +Require Import Chunks. + +(** * Abstract syntax *) + +(** A KVX program is syntactically given as a list of functions. + Each function is associated to a list of bundles of type [bblock] below. + Hence, syntactically, we view each bundle as a basic block: + this view induces our sequential semantics of bundles defined in [Asmblock]. +*) + +(** General Purpose registers. *) + +Inductive gpreg: Type := + | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg + | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg + | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg + | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg + | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg + | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg + | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg + | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg + | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg + | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg + | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg + | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg + | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. + +Definition ireg := gpreg. +Definition freg := gpreg. + +Lemma gpreg_eq: forall (x y: gpreg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Inductive gpreg_q : Type := +| R0R1 | R2R3 | R4R5 | R6R7 | R8R9 +| R10R11 | R12R13 | R14R15 | R16R17 | R18R19 +| R20R21 | R22R23 | R24R25 | R26R27 | R28R29 +| R30R31 | R32R33 | R34R35 | R36R37 | R38R39 +| R40R41 | R42R43 | R44R45 | R46R47 | R48R49 +| R50R51 | R52R53 | R54R55 | R56R57 | R58R59 +| R60R61 | R62R63. + +Lemma gpreg_q_eq : forall (x y : gpreg_q), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Definition gpreg_q_expand (x : gpreg_q) : gpreg * gpreg := + match x with + | R0R1 => (GPR0, GPR1) + | R2R3 => (GPR2, GPR3) + | R4R5 => (GPR4, GPR5) + | R6R7 => (GPR6, GPR7) + | R8R9 => (GPR8, GPR9) + | R10R11 => (GPR10, GPR11) + | R12R13 => (GPR12, GPR13) + | R14R15 => (GPR14, GPR15) + | R16R17 => (GPR16, GPR17) + | R18R19 => (GPR18, GPR19) + | R20R21 => (GPR20, GPR21) + | R22R23 => (GPR22, GPR23) + | R24R25 => (GPR24, GPR25) + | R26R27 => (GPR26, GPR27) + | R28R29 => (GPR28, GPR29) + | R30R31 => (GPR30, GPR31) + | R32R33 => (GPR32, GPR33) + | R34R35 => (GPR34, GPR35) + | R36R37 => (GPR36, GPR37) + | R38R39 => (GPR38, GPR39) + | R40R41 => (GPR40, GPR41) + | R42R43 => (GPR42, GPR43) + | R44R45 => (GPR44, GPR45) + | R46R47 => (GPR46, GPR47) + | R48R49 => (GPR48, GPR49) + | R50R51 => (GPR50, GPR51) + | R52R53 => (GPR52, GPR53) + | R54R55 => (GPR54, GPR55) + | R56R57 => (GPR56, GPR57) + | R58R59 => (GPR58, GPR59) + | R60R61 => (GPR60, GPR61) + | R62R63 => (GPR62, GPR63) + end. + +Inductive gpreg_o : Type := +| R0R1R2R3 | R4R5R6R7 | R8R9R10R11 | R12R13R14R15 +| R16R17R18R19 | R20R21R22R23 | R24R25R26R27 | R28R29R30R31 +| R32R33R34R35 | R36R37R38R39 | R40R41R42R43 | R44R45R46R47 +| R48R49R50R51 | R52R53R54R55 | R56R57R58R59 | R60R61R62R63. + +Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := + match x with + | R0R1R2R3 => (GPR0, GPR1, GPR2, GPR3) + | R4R5R6R7 => (GPR4, GPR5, GPR6, GPR7) + | R8R9R10R11 => (GPR8, GPR9, GPR10, GPR11) + | R12R13R14R15 => (GPR12, GPR13, GPR14, GPR15) + | R16R17R18R19 => (GPR16, GPR17, GPR18, GPR19) + | R20R21R22R23 => (GPR20, GPR21, GPR22, GPR23) + | R24R25R26R27 => (GPR24, GPR25, GPR26, GPR27) + | R28R29R30R31 => (GPR28, GPR29, GPR30, GPR31) + | R32R33R34R35 => (GPR32, GPR33, GPR34, GPR35) + | R36R37R38R39 => (GPR36, GPR37, GPR38, GPR39) + | R40R41R42R43 => (GPR40, GPR41, GPR42, GPR43) + | R44R45R46R47 => (GPR44, GPR45, GPR46, GPR47) + | R48R49R50R51 => (GPR48, GPR49, GPR50, GPR51) + | R52R53R54R55 => (GPR52, GPR53, GPR54, GPR55) + | R56R57R58R59 => (GPR56, GPR57, GPR58, GPR59) + | R60R61R62R63 => (GPR60, GPR61, GPR62, GPR63) + end. + +Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Inductive preg: Type := + | IR: gpreg -> preg (**r integer general purpose registers *) + | RA: preg + | PC: preg + . + +Coercion IR: gpreg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +(** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *) + +Notation "'SP'" := GPR12 (only parsing) : asm. +Notation "'FP'" := GPR17 (only parsing) : asm. +Notation "'MFP'" := R17 (only parsing) : asm. +Notation "'GPRA'" := GPR16 (only parsing) : asm. +Notation "'RTMP'" := GPR32 (only parsing) : asm. + +Inductive btest: Type := + | BTdnez (**r Double Not Equal to Zero *) + | BTdeqz (**r Double Equal to Zero *) + | BTdltz (**r Double Less Than Zero *) + | BTdgez (**r Double Greater Than or Equal to Zero *) + | BTdlez (**r Double Less Than or Equal to Zero *) + | BTdgtz (**r Double Greater Than Zero *) + | BTwnez (**r Word Not Equal to Zero *) + | BTweqz (**r Word Equal to Zero *) + | BTwltz (**r Word Less Than Zero *) + | BTwgez (**r Word Greater Than or Equal to Zero *) + | BTwlez (**r Word Less Than or Equal to Zero *) + | BTwgtz (**r Word Greater Than Zero *) + . + +Inductive itest: Type := + | ITne (**r Not Equal *) + | ITeq (**r Equal *) + | ITlt (**r Less Than *) + | ITge (**r Greater Than or Equal *) + | ITle (**r Less Than or Equal *) + | ITgt (**r Greater Than *) + | ITneu (**r Unsigned Not Equal *) + | ITequ (**r Unsigned Equal *) + | ITltu (**r Less Than Unsigned *) + | ITgeu (**r Greater Than or Equal Unsigned *) + | ITleu (**r Less Than or Equal Unsigned *) + | ITgtu (**r Greater Than Unsigned *) + . + +Inductive ftest: Type := + | FTone (**r Ordered and Not Equal *) + | FTueq (**r Unordered or Equal *) + | FToeq (**r Ordered and Equal *) + | FTune (**r Unordered or Not Equal *) + | FTolt (**r Ordered and Less Than *) + | FTuge (**r Unordered or Greater Than or Equal *) + | FToge (**r Ordered and Greater Than or Equal *) + | FTult (**r Unordered or Less Than *) + . + +(** Offsets for load and store instructions. An offset is either an + immediate integer or the low part of a symbol. *) + +Definition offset : Type := ptrofs. + +(** We model a subset of the KVX instruction set. In particular, we do not + support floats yet. + + Although it is possible to use the 32-bits mode, for now we don't support it. + + We follow a design close to the one used for the Risc-V port: one set of + pseudo-instructions for 32-bit integer arithmetic, with suffix W, another + set for 64-bit integer arithmetic, with suffix L. + + When mapping to actual instructions, the OCaml code in TargetPrinter.ml + throws an error if we are not in 64-bits mode. +*) + +(** * Instructions *) + +Definition label := positive. + +(** Instructions to be expanded in control-flow *) +Inductive ex_instruction : Type := + (* Pseudo-instructions *) + | Pbuiltin: external_function -> list (builtin_arg preg) + -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) +. + +(** FIXME: comment not up to date ! + + + The pseudo-instructions are the following: + +- [Ploadsymbol]: load the address of a symbol in an integer register. + Expands to the [la] assembler pseudo-instruction, which does the right + thing even if we are in PIC mode. + +- [Pallocframe sz pos]: in the formal semantics, this + pseudo-instruction allocates a memory block with bounds [0] and + [sz], stores the value of the stack pointer at offset [pos] in this + block, and sets the stack pointer to the address of the bottom of + this block. + In the printed ASM assembly code, this allocation is: +<< + mv x30, sp + sub sp, sp, #sz + sw x30, #pos(sp) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. + +- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction + reads the word at [pos] of the block pointed by the stack pointer, + frees this block, and sets the stack pointer to the value read. + In the printed ASM assembly code, this freeing is just an increment of [sp]: +<< + add sp, sp, #sz +>> + Again, our memory model cannot comprehend that this operation + frees (logically) the current stack frame. + +- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table + as follows: +<< + la x31, table + add x31, x31, reg + jr x31 +table: .long table[0], table[1], ... +>> + Note that [reg] contains 4 times the index of the desired table entry. +*) + +(** Control Flow instructions *) +Inductive cf_instruction : Type := + | Pret (**r return *) + | Pcall (l: label) (**r function call *) + | Picall (r: ireg) (**r function call on register value *) + | Pjumptable (r: ireg) (labels: list label) (**r N-way branch through a jump table (pseudo) *) + + (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) + | Pgoto (l: label) (**r goto *) + | Pigoto (r: ireg) (**r goto from register *) + | Pj_l (l: label) (**r jump to label *) + + (* Conditional branches *) + | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) + | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) +. + +(** Loads **) +Definition concrete_default_notrap_load_value (chunk : memory_chunk) := + match chunk with + | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned + | Mint32 => Vint Int.zero + | Mint64 => Vlong Int64.zero + | Many32 | Many64 => Vundef + | Mfloat32 => Vsingle Float32.zero + | Mfloat64 => Vfloat Float.zero + end. + +Inductive load_name : Type := + | Plb (**r load byte *) + | Plbu (**r load byte unsigned *) + | Plh (**r load half word *) + | Plhu (**r load half word unsigned *) + | Plw (**r load int32 *) + | Plw_a (**r load any32 *) + | Pld (**r load int64 *) + | Pld_a (**r load any64 *) + | Pfls (**r load float *) + | Pfld (**r load 64-bit float *) +. + +Inductive ld_instruction : Type := + | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) + | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) + | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) + | PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset) +. + +(** Stores **) +Inductive store_name : Type := + | Psb (**r store byte *) + | Psh (**r store half byte *) + | Psw (**r store int32 *) + | Psw_a (**r store any32 *) + | Psd (**r store int64 *) + | Psd_a (**r store any64 *) + | Pfss (**r store float *) + | Pfsd (**r store 64-bit float *) +. + +Inductive st_instruction : Type := + | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) + | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) + | PStoreRRRXS(i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) + | PStoreQRRO (rs: gpreg_q) (ra: ireg) (ofs: offset) + | PStoreORRO (rs: gpreg_o) (ra: ireg) (ofs: offset) +. + +(** Arithmetic instructions **) +Inductive arith_name_r : Type := + | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) +. + +Inductive arith_name_rr : Type := + | Pmv (**r register move *) + | Pnegw (**r negate word *) + | Pnegl (**r negate long *) + | Pcvtl2w (**r Convert Long to Word *) + | Psxwd (**r Sign Extend Word to Double Word *) + | Pzxwd (**r Zero Extend Word to Double Word *) + | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) + | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) + | Pextfzl (stop : Z) (start : Z) (**r extract bit field, unsigned *) + | Pextfsl (stop : Z) (start : Z) (**r extract bit field, signed *) + + | Pfabsd (**r float absolute double *) + | Pfabsw (**r float absolute word *) + | Pfnegd (**r float negate double *) + | Pfnegw (**r float negate word *) + | Pfinvw (**r float invert word *) + | Pfnarrowdw (**r float narrow 64 -> 32 bits *) + | Pfwidenlwd (**r Floating Point widen from 32 bits to 64 bits *) + | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) + | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) + | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) + | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) + | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) + | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) + | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) + | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) + | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) + | Pfixedudrzz_i32 (**r Integer conversion from floating point (float -> unsigned int) *) +. + +Inductive arith_name_ri32 : Type := + | Pmake (**r load immediate *) +. + +Inductive arith_name_ri64 : Type := + | Pmakel (**r load immediate long *) +. + +Inductive arith_name_rf32 : Type := + | Pmakefs (**r load immediate single *) +. + +Inductive arith_name_rf64 : Type := + | Pmakef (**r load immediate float *) +. + +Inductive arith_name_rrr : Type := + | Pcompw (it: itest) (**r comparison word *) + | Pcompl (it: itest) (**r comparison long *) + | Pfcompw (ft: ftest) (**r comparison float32 *) + | Pfcompl (ft: ftest) (**r comparison float64 *) + + | Paddw (**r add word *) + | Paddxw (shift : shift1_4) (**r add shift *) + | Psubw (**r sub word word *) + | Prevsubxw (shift : shift1_4) (**r sub shift word *) + | Pmulw (**r mul word *) + | Pandw (**r and word *) + | Pnandw (**r nand word *) + | Porw (**r or word *) + | Pnorw (**r nor word *) + | Pxorw (**r xor word *) + | Pnxorw (**r nxor word *) + | Pandnw (**r andn word *) + | Pornw (**r orn word *) + | Psraw (**r shift right arithmetic word *) + | Psrxw (**r shift right arithmetic word round to 0*) + | Psrlw (**r shift right logical word *) + | Psllw (**r shift left logical word *) + + | Paddl (**r add long *) + | Paddxl (shift : shift1_4) (**r add shift long *) + | Psubl (**r sub long *) + | Prevsubxl (shift : shift1_4) (**r sub shift long *) + | Pandl (**r and long *) + | Pnandl (**r nand long *) + | Porl (**r or long *) + | Pnorl (**r nor long *) + | Pxorl (**r xor long *) + | Pnxorl (**r nxor long *) + | Pandnl (**r andn long *) + | Pornl (**r orn long *) + | Pmull (**r mul long (low part) *) + | Pslll (**r shift left logical long *) + | Psrll (**r shift right logical long *) + | Psrxl (**r shift right logical long round to 0*) + | Psral (**r shift right arithmetic long *) + + | Pfaddd (**r float add double *) + | Pfaddw (**r float add word *) + | Pfsbfd (**r float sub double *) + | Pfsbfw (**r float sub word *) + | Pfmuld (**r float multiply double *) + | Pfmulw (**r float multiply word *) + | Pfmind (**r float min double *) + | Pfminw (**r float min word *) + | Pfmaxd (**r float max double *) + | Pfmaxw (**r float max word *) +. + +Inductive arith_name_rri32 : Type := + | Pcompiw (it: itest) (**r comparison imm word *) + + | Paddiw (**r add imm word *) + | Paddxiw (shift : shift1_4) + | Prevsubiw (**r add imm word *) + | Prevsubxiw (shift : shift1_4) + | Pmuliw (**r add imm word *) + | Pandiw (**r and imm word *) + | Pnandiw (**r nand imm word *) + | Poriw (**r or imm word *) + | Pnoriw (**r nor imm word *) + | Pxoriw (**r xor imm word *) + | Pnxoriw (**r nxor imm word *) + | Pandniw (**r andn word *) + | Porniw (**r orn word *) + | Psraiw (**r shift right arithmetic imm word *) + | Psrxiw (**r shift right arithmetic imm word round to 0*) + | Psrliw (**r shift right logical imm word *) + | Pslliw (**r shift left logical imm word *) + | Proriw (**r rotate right imm word *) + | Psllil (**r shift left logical immediate long *) + | Psrlil (**r shift right logical immediate long *) + | Psrail (**r shift right arithmetic immediate long *) + | Psrxil (**r shift right arithmetic immediate long round to 0*) +. + +Inductive arith_name_rri64 : Type := + | Pcompil (it: itest) (**r comparison imm long *) + | Paddil (**r add immediate long *) + | Paddxil (shift : shift1_4) + | Prevsubil + | Prevsubxil (shift : shift1_4) + | Pmulil (**r mul immediate long *) + | Pandil (**r and immediate long *) + | Pnandil (**r nand immediate long *) + | Poril (**r or immediate long *) + | Pnoril (**r nor immediate long *) + | Pxoril (**r xor immediate long *) + | Pnxoril (**r nxor immediate long *) + | Pandnil (**r andn immediate long *) + | Pornil (**r orn immediate long *) +. + +Inductive arith_name_arrr : Type := + | Pmaddw (**r multiply add word *) + | Pmaddl (**r multiply add long *) + | Pmsubw (**r multiply subtract word *) + | Pmsubl (**r multiply subtract long *) + | Pcmove (bt: btest) (**r conditional move *) + | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) + | Pfmaddfw (**r float fused multiply add word *) + | Pfmaddfl (**r float fused multiply add long *) + | Pfmsubfw (**r float fused multiply subtract word *) + | Pfmsubfl (**r float fused multiply subtract long *) +. + +Inductive arith_name_arri32 : Type := + | Pmaddiw (**r multiply add word *) + | Pcmoveiw (bt: btest) + | Pcmoveuiw (bt: btest) +. + +Inductive arith_name_arri64 : Type := + | Pmaddil (**r multiply add long *) + | Pcmoveil (bt: btest) + | Pcmoveuil (bt: btest) +. + +Inductive arith_name_arr : Type := + | Pinsf (stop : Z) (start : Z) (**r insert bit field *) + | Pinsfl (stop : Z) (start : Z) (**r insert bit field *) +. + +Inductive ar_instruction : Type := + | PArithR (i: arith_name_r) (rd: ireg) + | PArithRR (i: arith_name_rr) (rd rs: ireg) + | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) + | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) + | PArithRF32 (i: arith_name_rf32) (rd: ireg) (imm: float32) + | PArithRF64 (i: arith_name_rf64) (rd: ireg) (imm: float) + | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) + | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) + | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) + | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) + | PArithARR (i: arith_name_arr) (rd rs: ireg) + | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) + | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) +. + +Module PArithCoercions. + +Coercion PArithR: arith_name_r >-> Funclass. +Coercion PArithRR: arith_name_rr >-> Funclass. +Coercion PArithRI32: arith_name_ri32 >-> Funclass. +Coercion PArithRI64: arith_name_ri64 >-> Funclass. +Coercion PArithRF32: arith_name_rf32 >-> Funclass. +Coercion PArithRF64: arith_name_rf64 >-> Funclass. +Coercion PArithRRR: arith_name_rrr >-> Funclass. +Coercion PArithRRI32: arith_name_rri32 >-> Funclass. +Coercion PArithRRI64: arith_name_rri64 >-> Funclass. +Coercion PArithARRR: arith_name_arrr >-> Funclass. +Coercion PArithARR: arith_name_arr >-> Funclass. +Coercion PArithARRI32: arith_name_arri32 >-> Funclass. +Coercion PArithARRI64: arith_name_arri64 >-> Funclass. + +End PArithCoercions. + +Inductive basic : Type := + | PArith (i: ar_instruction) + | PLoad (i: ld_instruction) + | PStore (i: st_instruction) + | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) + | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) + | Pget (rd: ireg) (rs: preg) (**r get system register *) + | Pset (rd: preg) (rs: ireg) (**r set system register *) + | Pnop (**r virtual instruction that does nothing *) +. + +Coercion PLoad: ld_instruction >-> basic. +Coercion PStore: st_instruction >-> basic. +Coercion PArith: ar_instruction >-> basic. + + +Inductive control : Type := + | PExpand (i: ex_instruction) + | PCtlFlow (i: cf_instruction) +. + +Coercion PExpand: ex_instruction >-> control. +Coercion PCtlFlow: cf_instruction >-> control. + + +(** * Definition of a bblock (ie a bundle) + +A bundle/bblock must contain at least one instruction. + +This choice simplifies the definition of [find_bblock] below: +indeed, each address of a code block identifies at most one bundle +(which depends on the number of instructions in the bundles of lower addresses). + +*) + +Definition non_empty_body (body: list basic): bool := + match body with + | nil => false + | _ => true + end. + +Definition non_empty_exit (exit: option control): bool := + match exit with + | None => false + | _ => true + end. + +Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. + + +(** TODO + * For now, we consider a builtin is alone in a bundle (and a basic block). + * Is there a way to avoid that ? + *) +Definition builtin_aloneb (body: list basic) (exit: option control) := + match exit with + | Some (PExpand (Pbuiltin _ _ _)) => + match body with + | nil => true + | _ => false + end + | _ => true + end. + +Definition wf_bblockb (body: list basic) (exit: option control) := + (non_empty_bblockb body exit) && (builtin_aloneb body exit). + +(** A bblock is well-formed if he contains at least one instruction, + and if there is a builtin then it must be alone in this bblock. *) + +Record bblock := mk_bblock { + header: list label; + body: list basic; + exit: option control; + correct: Is_true (wf_bblockb body exit) +}. + +(* FIXME? redundant with definition in Machblock *) +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +(* WARNING: the notion of size is not the same than in Machblock ! + We ignore labels here... + + This notion of size induces the notion of "valid" code address given by [find_bblock] + + The result is in Z to be compatible with operations on PC. +*) +Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). + +Definition bblocks := list bblock. + +Fixpoint size_blocks (l: bblocks): Z := + match l with + | nil => 0 + | b :: l => + (size b) + (size_blocks l) + end + . + +Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +(** * Operational semantics *) + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain + the convention that integer registers are mapped to values of + type [Tint] or [Tlong] (in 64 bit mode), + and float registers to values of type [Tsingle] or [Tfloat]. *) + +Definition regset := Pregmap.t val. + +Definition genv := Genv.t fundef unit. + +Notation "a # b" := (a b) (at level 1, only parsing) : asm. +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. + +Open Scope asm. + +(** Undefining some registers *) + +Fixpoint undef_regs (l: list preg) (rs: regset) : regset := + match l with + | nil => rs + | r :: l' => undef_regs l' (rs#r <- Vundef) + end. + + +(** Assigning a register pair *) +Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := + match p with + | One r => rs#r <- v + | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) + end. + + +(** Assigning the result of a builtin *) + +Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := + match res with + | BR r => rs#r <- v + | BR_none => rs + | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) + end. + +Local Open Scope asm. + +(** * Parallel Semantics of bundles *) + +Section RELSEM. + +(** Execution of arith instructions *) + +Variable ge: genv. + +(** The parallel semantics on bundles is purely small-step and defined as a relation + from the current state (a register set + a memory state) to either [Next rs' m'] + where [rs'] and [m'] are the updated register set and memory state after execution + of the instruction at [rs#PC], or [Stuck] if the processor is stuck. + + The parallel semantics of each instructions handles two states in input: + - the actual input state of the bundle which is only read + - and the other on which every "write" is performed: + it represents a temporary "writes" buffer, from which the final state + of the bundle is computed. + + NB: the sequential semantics defined in [Asmblock] is derived + from the parallel semantics of each instruction by identifying + the read state and the write state. + +*) + +Inductive outcome: Type := + | Next (rs:regset) (m:mem) + | Stuck +. + +(** ** Arithmetic Expressions (including comparisons) *) + +Inductive signedness: Type := Signed | Unsigned. + +Inductive intsize: Type := Int | Long. + +Definition itest_for_cmp (c: comparison) (s: signedness) := + match c, s with + | Cne, Signed => ITne + | Ceq, Signed => ITeq + | Clt, Signed => ITlt + | Cge, Signed => ITge + | Cle, Signed => ITle + | Cgt, Signed => ITgt + | Cne, Unsigned => ITneu + | Ceq, Unsigned => ITequ + | Clt, Unsigned => ITltu + | Cge, Unsigned => ITgeu + | Cle, Unsigned => ITleu + | Cgt, Unsigned => ITgtu + end. + +Inductive oporder_ftest := + | Normal (ft: ftest) + | Reversed (ft: ftest) +. + +Definition ftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FToeq + | Cne => Normal FTune + | Clt => Normal FTolt + | Cle => Reversed FToge + | Cgt => Reversed FTolt + | Cge => Normal FToge + end. + +Definition notftest_for_cmp (c: comparison) := + match c with + | Ceq => Normal FTune + | Cne => Normal FToeq + | Clt => Normal FTuge + | Cle => Reversed FTult + | Cgt => Reversed FTuge + | Cge => Normal FTult + end. + +(* CoMPare Signed Words to Zero *) +Definition btest_for_cmpswz (c: comparison) := + match c with + | Cne => BTwnez + | Ceq => BTweqz + | Clt => BTwltz + | Cge => BTwgez + | Cle => BTwlez + | Cgt => BTwgtz + end. + +(* CoMPare Signed Doubles to Zero *) +Definition btest_for_cmpsdz (c: comparison) := + match c with + | Cne => BTdnez + | Ceq => BTdeqz + | Clt => BTdltz + | Cge => BTdgez + | Cle => BTdlez + | Cgt => BTdgtz + end. + +Definition cmp_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTwltz => (Some Clt, Int) + | BTwgez => (Some Cge, Int) + | BTwlez => (Some Cle, Int) + | BTwgtz => (Some Cgt, Int) + + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | BTdltz => (Some Clt, Long) + | BTdgez => (Some Cge, Long) + | BTdlez => (Some Cle, Long) + | BTdgtz => (Some Cgt, Long) + end. + +Definition cmpu_for_btest (bt: btest) := + match bt with + | BTwnez => (Some Cne, Int) + | BTweqz => (Some Ceq, Int) + | BTdnez => (Some Cne, Long) + | BTdeqz => (Some Ceq, Long) + | _ => (None, Int) + end. + + +(* a few lemma on comparisons of unsigned (e.g. pointers) *) + +Definition Val_cmpu_bool cmp v1 v2: option bool := + Val.cmpu_bool (fun _ _ => true) cmp v1 v2. + +Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: + (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmpu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). + +Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): + Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) + (Val_cmpu cmp v1 v2). +Proof. + unfold Val.cmpu, Val_cmpu. + remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob; simpl. + - erewrite Val_cmpu_bool_correct; eauto. + econstructor. + - econstructor. +Qed. + +Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) + := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). + +Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: + (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b + -> (Val_cmplu_bool cmp v1 v2) = Some b. +Proof. + intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). +Qed. + +Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). + +Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): + Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) + (Val_cmplu cmp v1 v2). +Proof. + unfold Val.cmplu, Val_cmplu. + remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. + destruct ob as [b|]; simpl. + - erewrite Val_cmplu_bool_correct; eauto. + simpl. econstructor. + - econstructor. +Qed. + + + +(** Comparing integers *) +Definition compare_int (t: itest) (v1 v2: val): val := + match t with + | ITne => Val.cmp Cne v1 v2 + | ITeq => Val.cmp Ceq v1 v2 + | ITlt => Val.cmp Clt v1 v2 + | ITge => Val.cmp Cge v1 v2 + | ITle => Val.cmp Cle v1 v2 + | ITgt => Val.cmp Cgt v1 v2 + | ITneu => Val_cmpu Cne v1 v2 + | ITequ => Val_cmpu Ceq v1 v2 + | ITltu => Val_cmpu Clt v1 v2 + | ITgeu => Val_cmpu Cge v1 v2 + | ITleu => Val_cmpu Cle v1 v2 + | ITgtu => Val_cmpu Cgt v1 v2 + end. + +Definition compare_long (t: itest) (v1 v2: val): val := + let res := match t with + | ITne => Val.cmpl Cne v1 v2 + | ITeq => Val.cmpl Ceq v1 v2 + | ITlt => Val.cmpl Clt v1 v2 + | ITge => Val.cmpl Cge v1 v2 + | ITle => Val.cmpl Cle v1 v2 + | ITgt => Val.cmpl Cgt v1 v2 + | ITneu => Some (Val_cmplu Cne v1 v2) + | ITequ => Some (Val_cmplu Ceq v1 v2) + | ITltu => Some (Val_cmplu Clt v1 v2) + | ITgeu => Some (Val_cmplu Cge v1 v2) + | ITleu => Some (Val_cmplu Cle v1 v2) + | ITgtu => Some (Val_cmplu Cgt v1 v2) + end in + match res with + | Some v => v + | None => Vundef + end + . + +Definition compare_single (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpfs Ceq v1 v2 + | FTune => Val.cmpfs Cne v1 v2 + | FTolt => Val.cmpfs Clt v1 v2 + | FTuge => Val.notbool (Val.cmpfs Clt v1 v2) + | FToge => Val.cmpfs Cge v1 v2 + | FTult => Val.notbool (Val.cmpfs Cge v1 v2) + end. + +Definition compare_float (t: ftest) (v1 v2: val): val := + match t with + | FTone | FTueq => Vundef (* unused *) + | FToeq => Val.cmpf Ceq v1 v2 + | FTune => Val.cmpf Cne v1 v2 + | FTolt => Val.cmpf Clt v1 v2 + | FTuge => Val.notbool (Val.cmpf Clt v1 v2) + | FToge => Val.cmpf Cge v1 v2 + | FTult => Val.notbool (Val.cmpf Cge v1 v2) + end. + +Definition arith_eval_r n := + match n with + | Ploadsymbol s ofs => Genv.symbol_address ge s ofs + end +. + +Definition arith_eval_rr n v := + match n with + | Pmv => v + | Pnegw => Val.neg v + | Pnegl => Val.negl v + | Pcvtl2w => Val.loword v + | Psxwd => Val.longofint v + | Pzxwd => Val.longofintu v + | Pextfz stop start => extfz stop start v + | Pextfs stop start => extfs stop start v + | Pextfzl stop start => extfzl stop start v + | Pextfsl stop start => extfsl stop start v + | Pfnegd => Val.negf v + | Pfnegw => Val.negfs v + | Pfabsd => Val.absf v + | Pfabsw => Val.absfs v + | Pfinvw => ExtValues.invfs v + | Pfnarrowdw => Val.singleoffloat v + | Pfwidenlwd => Val.floatofsingle v + | Pfloatwrnsz => Val.maketotal (Val.singleofint v) + | Pfloatuwrnsz => Val.maketotal (Val.singleofintu v) + | Pfloatudrnsz => Val.maketotal (Val.floatoflongu v) + | Pfloatdrnsz => Val.maketotal (Val.floatoflong v) + | Pfixedwrzz => Val.maketotal (Val.intofsingle v) + | Pfixeduwrzz => Val.maketotal (Val.intuofsingle v) + | Pfixeddrzz => Val.maketotal (Val.longoffloat v) + | Pfixedudrzz => Val.maketotal (Val.longuoffloat v) + | Pfixeddrzz_i32 => Val.maketotal (Val.intoffloat v) + | Pfixedudrzz_i32 => Val.maketotal (Val.intuoffloat v) + end. + +Definition arith_eval_ri32 n i := + match n with + | Pmake => Vint i + end. + +Definition arith_eval_ri64 n i := + match n with + | Pmakel => Vlong i + end. + +Definition arith_eval_rf32 n i := + match n with + | Pmakefs => Vsingle i + end. + +Definition arith_eval_rf64 n i := + match n with + | Pmakef => Vfloat i + end. + +Definition arith_eval_rrr n v1 v2 := + match n with + | Pcompw c => compare_int c v1 v2 + | Pcompl c => compare_long c v1 v2 + | Pfcompw c => compare_single c v1 v2 + | Pfcompl c => compare_float c v1 v2 + + | Paddw => Val.add v1 v2 + | Psubw => Val.sub v1 v2 + | Pmulw => Val.mul v1 v2 + | Pandw => Val.and v1 v2 + | Pnandw => Val.notint (Val.and v1 v2) + | Porw => Val.or v1 v2 + | Pnorw => Val.notint (Val.or v1 v2) + | Pxorw => Val.xor v1 v2 + | Pnxorw => Val.notint (Val.xor v1 v2) + | Pandnw => Val.and (Val.notint v1) v2 + | Pornw => Val.or (Val.notint v1) v2 + | Psrlw => Val.shru v1 v2 + | Psraw => Val.shr v1 v2 + | Psllw => Val.shl v1 v2 + | Psrxw => ExtValues.val_shrx v1 v2 + + | Paddl => Val.addl v1 v2 + | Psubl => Val.subl v1 v2 + | Pandl => Val.andl v1 v2 + | Pnandl => Val.notl (Val.andl v1 v2) + | Porl => Val.orl v1 v2 + | Pnorl => Val.notl (Val.orl v1 v2) + | Pxorl => Val.xorl v1 v2 + | Pnxorl => Val.notl (Val.xorl v1 v2) + | Pandnl => Val.andl (Val.notl v1) v2 + | Pornl => Val.orl (Val.notl v1) v2 + | Pmull => Val.mull v1 v2 + | Pslll => Val.shll v1 v2 + | Psrll => Val.shrlu v1 v2 + | Psral => Val.shrl v1 v2 + | Psrxl => ExtValues.val_shrxl v1 v2 + + | Pfaddd => Val.addf v1 v2 + | Pfaddw => Val.addfs v1 v2 + | Pfsbfd => Val.subf v1 v2 + | Pfsbfw => Val.subfs v1 v2 + | Pfmuld => Val.mulf v1 v2 + | Pfmulw => Val.mulfs v1 v2 + + | Pfmind => ExtValues.minf v1 v2 + | Pfminw => ExtValues.minfs v1 v2 + | Pfmaxd => ExtValues.maxf v1 v2 + | Pfmaxw => ExtValues.maxfs v1 v2 + + | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 + | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 + + | Prevsubxw shift => ExtValues.revsubx (int_of_shift1_4 shift) v1 v2 + | Prevsubxl shift => ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2 + end. + +Definition arith_eval_rri32 n v i := + match n with + | Pcompiw c => compare_int c v (Vint i) + | Paddiw => Val.add v (Vint i) + | Prevsubiw => Val.sub (Vint i) v + | Pmuliw => Val.mul v (Vint i) + | Pandiw => Val.and v (Vint i) + | Pnandiw => Val.notint (Val.and v (Vint i)) + | Poriw => Val.or v (Vint i) + | Pnoriw => Val.notint (Val.or v (Vint i)) + | Pxoriw => Val.xor v (Vint i) + | Pnxoriw => Val.notint (Val.xor v (Vint i)) + | Pandniw => Val.and (Val.notint v) (Vint i) + | Porniw => Val.or (Val.notint v) (Vint i) + | Psraiw => Val.shr v (Vint i) + | Psrxiw => ExtValues.val_shrx v (Vint i) + | Psrliw => Val.shru v (Vint i) + | Pslliw => Val.shl v (Vint i) + | Proriw => Val.ror v (Vint i) + | Psllil => Val.shll v (Vint i) + | Psrxil => ExtValues.val_shrxl v (Vint i) + | Psrlil => Val.shrlu v (Vint i) + | Psrail => Val.shrl v (Vint i) + | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) + | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i) + end. + +Definition arith_eval_rri64 n v i := + match n with + | Pcompil c => compare_long c v (Vlong i) + | Paddil => Val.addl v (Vlong i) + | Prevsubil => Val.subl (Vlong i) v + | Pmulil => Val.mull v (Vlong i) + | Pandil => Val.andl v (Vlong i) + | Pnandil => Val.notl (Val.andl v (Vlong i)) + | Poril => Val.orl v (Vlong i) + | Pnoril => Val.notl (Val.orl v (Vlong i)) + | Pxoril => Val.xorl v (Vlong i) + | Pnxoril => Val.notl (Val.xorl v (Vlong i)) + | Pandnil => Val.andl (Val.notl v) (Vlong i) + | Pornil => Val.orl (Val.notl v) (Vlong i) + | Paddxil shift => ExtValues.addxl (int_of_shift1_4 shift) v (Vlong i) + | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i) + end. + +Definition cmove bt v1 v2 v3 := + match cmp_for_btest bt with + | (Some c, Int) => + match Val.cmp_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val.cmpl_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef + end. + +Definition cmoveu bt v1 v2 v3 := + match cmpu_for_btest bt with + | (Some c, Int) => + match Val_cmpu_bool c v2 (Vint Int.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (Some c, Long) => + match Val_cmplu_bool c v2 (Vlong Int64.zero) with + | None => Vundef + | Some true => v3 + | Some false => v1 + end + | (None, _) => Vundef + end. + +Definition arith_eval_arrr n v1 v2 v3 := + match n with + | Pmaddw => Val.add v1 (Val.mul v2 v3) + | Pmaddl => Val.addl v1 (Val.mull v2 v3) + | Pmsubw => Val.sub v1 (Val.mul v2 v3) + | Pmsubl => Val.subl v1 (Val.mull v2 v3) + | Pcmove bt => cmove bt v1 v2 v3 + | Pcmoveu bt => cmoveu bt v1 v2 v3 + | Pfmaddfw => ExtValues.fmaddfs v1 v2 v3 + | Pfmaddfl => ExtValues.fmaddf v1 v2 v3 + | Pfmsubfw => ExtValues.fmsubfs v1 v2 v3 + | Pfmsubfl => ExtValues.fmsubf v1 v2 v3 + end. + +Definition arith_eval_arr n v1 v2 := + match n with + | Pinsf stop start => ExtValues.insf stop start v1 v2 + | Pinsfl stop start => ExtValues.insfl stop start v1 v2 + end. + +Definition arith_eval_arri32 n v1 v2 v3 := + match n with + | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) + | Pcmoveiw bt => cmove bt v1 v2 (Vint v3) + | Pcmoveuiw bt => cmoveu bt v1 v2 (Vint v3) + end. + +Definition arith_eval_arri64 n v1 v2 v3 := + match n with + | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) + | Pcmoveil bt => cmove bt v1 v2 (Vlong v3) + | Pcmoveuil bt => cmoveu bt v1 v2 (Vlong v3) + end. + +Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := + match ai with + | PArithR n d => rsw#d <- (arith_eval_r n) + + | PArithRR n d s => rsw#d <- (arith_eval_rr n rsr#s) + + | PArithRI32 n d i => rsw#d <- (arith_eval_ri32 n i) + | PArithRI64 n d i => rsw#d <- (arith_eval_ri64 n i) + | PArithRF32 n d i => rsw#d <- (arith_eval_rf32 n i) + | PArithRF64 n d i => rsw#d <- (arith_eval_rf64 n i) + + | PArithRRR n d s1 s2 => rsw#d <- (arith_eval_rrr n rsr#s1 rsr#s2) + | PArithRRI32 n d s i => rsw#d <- (arith_eval_rri32 n rsr#s i) + | PArithRRI64 n d s i => rsw#d <- (arith_eval_rri64 n rsr#s i) + + | PArithARRR n d s1 s2 => rsw#d <- (arith_eval_arrr n rsr#d rsr#s1 rsr#s2) + | PArithARR n d s => rsw#d <- (arith_eval_arr n rsr#d rsr#s) + | PArithARRI32 n d s i => rsw#d <- (arith_eval_arri32 n rsr#d rsr#s i) + | PArithARRI64 n d s i => rsw#d <- (arith_eval_arri64 n rsr#d rsr#s i) + end. + +Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. + +(** * load/store *) + +Definition parexec_incorrect_load trap chunk d rsw mw := + match trap with + | TRAP => Stuck + | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw + end. + +Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := + match (eval_offset ofs) with + | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with + | None => parexec_incorrect_load trap chunk d rsw mw + | Some v => Next (rsw#d <- v) mw + end + | _ => Stuck + end. + +Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := + let (rd0, rd1) := gpreg_q_expand d in +(* NB: By construction of [gpreg_q], register rd0 and rd1 are distinct, thus, the register writes cannot overlap. + But we do not need to express/prove this in the semantics. +*) + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with + | None => Stuck + | Some v0 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with + | None => Stuck + | Some v1 => Next (rsw#rd0 <- v0 #rd1 <- v1) mw + end + end. + +Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := + match gpreg_o_expand d with + | (rd0, rd1, rd2, rd3) => +(* NB: By construction of [gpreg_o], the four destination registers are pairwise distinct, thus, the register writes cannot overlap. + But we do not need to express/prove this in the semantics. +*) + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with + | None => Stuck + | Some v0 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with + | None => Stuck + | Some v1 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) with + | None => Stuck + | Some v2 => + match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) with + | None => Stuck + | Some v3 => + Next (rsw#rd0 <- v0 #rd1 <- v1 #rd2 <- v2 #rd3 <- v3) mw + end + end + end + end + end. + +Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := + match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with + | None => parexec_incorrect_load trap chunk d rsw mw + | Some v => Next (rsw#d <- v) mw + end. + +Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := + match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with + | None => parexec_incorrect_load trap chunk d rsw mw + | Some v => Next (rsw#d <- v) mw + end. + +Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := + match (eval_offset ofs) with + | OK ptr => match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end + | _ => Stuck + end. + +Definition parexec_store_reg + (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := + match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end. + +Definition parexec_store_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := + match Mem.storev chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) (rsr s) with + | None => Stuck + | Some m' => Next rsw m' + end. + +Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := + let (s0, s1) := gpreg_q_expand s in + match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with + | None => Stuck + | Some m1 => + match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with + | None => Stuck + | Some m2 => Next rsw m2 + end + end. + +Definition parexec_store_o_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := + match gpreg_o_expand s with + | (s0, s1, s2, s3) => + match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with + | None => Stuck + | Some m1 => + match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with + | None => Stuck + | Some m2 => + match Mem.storev Many64 m2 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) (rsr s2) with + | None => Stuck + | Some m3 => + match Mem.storev Many64 m3 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) (rsr s3) with + | None => Stuck + | Some m4 => Next rsw m4 + end + end + end + end + end. + + +Definition load_chunk n := + match n with + | Plb => Mint8signed + | Plbu => Mint8unsigned + | Plh => Mint16signed + | Plhu => Mint16unsigned + | Plw => Mint32 + | Plw_a => Many32 + | Pld => Mint64 + | Pld_a => Many64 + | Pfls => Mfloat32 + | Pfld => Mfloat64 + end. + +Definition store_chunk n := + match n with + | Psb => Mint8unsigned + | Psh => Mint16unsigned + | Psw => Mint32 + | Psw_a => Many32 + | Psd => Mint64 + | Psd_a => Many64 + | Pfss => Mfloat32 + | Pfsd => Mfloat64 + end. + +(** * basic instructions *) + +Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := + match bi with + | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw + + | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs + | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro + | PLoad (PLoadQRRO d a ofs) => + parexec_load_q_offset rsr rsw mr mw d a ofs + | PLoad (PLoadORRO d a ofs) => + parexec_load_o_offset rsr rsw mr mw d a ofs + + | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs + | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro + | PStoreRRRXS n s a ro => parexec_store_regxs (store_chunk n) rsr rsw mr mw s a ro + | PStoreQRRO s a ofs => + parexec_store_q_offset rsr rsw mr mw s a ofs + | PStoreORRO s a ofs => + parexec_store_o_offset rsr rsw mr mw s a ofs + + | Pallocframe sz pos => + let (mw, stk) := Mem.alloc mr 0 sz in + let sp := (Vptr stk Ptrofs.zero) in + match Mem.storev Mptr mw (Val.offset_ptr sp pos) rsr#SP with + | None => Stuck + | Some mw => Next (rsw #FP <- (rsr SP) #SP <- sp #RTMP <- Vundef) mw + end + + | Pfreeframe sz pos => + match Mem.loadv Mptr mr (Val.offset_ptr rsr#SP pos) with + | None => Stuck + | Some v => + match rsr SP with + | Vptr stk ofs => + match Mem.free mr stk 0 sz with + | None => Stuck + | Some mw => Next (rsw#SP <- v #RTMP <- Vundef) mw + end + | _ => Stuck + end + end + | Pget rd ra => + match ra with + | RA => Next (rsw#rd <- (rsr#ra)) mw + | _ => Stuck + end + | Pset ra rd => + match ra with + | RA => Next (rsw#ra <- (rsr#rd)) mw + | _ => Stuck + end + | Pnop => Next rsw mw +end. + +(* parexec with writes-in-order *) +Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := + match body with + | nil => Next rsw mw + | bi::body' => + match bstep bi rsr rsw mr mw with + | Next rsw mw => parexec_wio_body body' rsr rsw mr mw + | Stuck => Stuck + end + end. + +(** TODO: redundant w.r.t Machblock ?? *) +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + + + +(** Note: copy-paste from Machblock *) +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + + +(** convert a label into a position in the code *) +Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := + match lb with + | nil => None + | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' + end. + +Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := + match label_pos lbl 0 (fn_blocks f) with + | None => Stuck + | Some pos => + match rsr#PC with + | Vptr b ofs => Next (rsw#PC <- (Vptr b (Ptrofs.repr pos))) mw + | _ => Stuck + end + end. + +(** Evaluating a branch + +Warning: in m PC is assumed to be already pointing on the next instruction ! + +*) + +Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) (res: option bool) := + match res with + | Some true => par_goto_label f l rsr rsw mw + | Some false => Next (rsw # PC <- (rsr PC)) mw + | None => Stuck + end. + + +(* FIXME: comment not up-to-date for parallel semantics *) + +(** Execution of a single control-flow instruction [i] in initial state [rs] and + [m]. Return updated state. + + As above: PC is assumed to be incremented on the next block before the control-flow instruction + + For instructions that correspond tobuiltin + actual RISC-V instructions, the cases are straightforward + transliterations of the informal descriptions given in the RISC-V + user-mode specification. For pseudo-instructions, refer to the + informal descriptions given above. + + Note that we set to [Vundef] the registers used as temporaries by + the expansions of the pseudo-instructions, so that the RISC-V code + we generate cannot use those registers to hold values that must + survive the execution of the pseudo-instruction. *) + +Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) (mw: mem) := + match oc with + | Some ic => +(** Get/Set system registers *) + match ic with + + +(** Branch Control Unit instructions *) + | Pret => + Next (rsw#PC <- (rsr#RA)) mw + | Pcall s => + Next (rsw#RA <- (rsr#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw + | Picall r => + Next (rsw#RA <- (rsr#PC) #PC <- (rsr#r)) mw + | Pjumptable r tbl => + match rsr#r with + | Vint n => + match list_nth_z tbl (Int.unsigned n) with + | None => Stuck + | Some lbl => par_goto_label f lbl rsr (rsw #GPR62 <- Vundef #GPR63 <- Vundef) mw + end + | _ => Stuck + end + | Pgoto s => + Next (rsw#PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw + | Pigoto r => + Next (rsw#PC <- (rsr#r)) mw + | Pj_l l => + par_goto_label f l rsr rsw mw + | Pcb bt r l => + match cmp_for_btest bt with + | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val.cmp_bool c rsr#r (Vint (Int.repr 0))) + | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val.cmpl_bool c rsr#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + | Pcbu bt r l => + match cmpu_for_btest bt with + | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val_cmpu_bool c rsr#r (Vint (Int.repr 0))) + | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val_cmplu_bool c rsr#r (Vlong (Int64.repr 0))) + | (None, _) => Stuck + end + +(** Pseudo-instructions *) + | Pbuiltin ef args res => + Stuck (**r treated specially below *) + end + | None => Next (rsw#PC <- (rsr#PC)) mw +end. + + +Definition incrPC size_b (rs: regset) := + rs#PC <- (Val.offset_ptr rs#PC size_b). + +(** parallel execution of the exit instruction of a bundle *) +Definition estep (f: function) ext size_b (rsr rsw: regset) (mw: mem) + := parexec_control f ext (incrPC size_b rsr) rsw mw. + +Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome := + match parexec_wio_body bdy rs rs m m with + | Next rsw mw => estep f ext size_b rs rsw mw + | Stuck => Stuck + end. + +(** non-deterministic (out-of-order writes) parallel execution of bundles *) +Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) (o: outcome): Prop := + exists bdy1 bdy2, Permutation (bdy1++bdy2) (body bundle) /\ + o=match parexec_wio f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs m with + | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw + | Stuck => Stuck + end. + +(** deterministic parallel (out-of-order writes) execution of bundles *) +Definition det_parexec (f: function) (bundle: bblock) (rs: regset) (m: mem) rs' m': Prop := + forall o, parexec_bblock f bundle rs m o -> o = Next rs' m'. + + +(* FIXME: comment not up-to-date *) +(** Translation of the LTL/Linear/Mach view of machine registers to + the RISC-V view. Note that no LTL register maps to [X31]. This + register is reserved as temporary, to be used by the generated RV32G + code. *) + + +(* FIXME - R16 and R32 are excluded *) +Definition preg_of (r: mreg) : preg := + match r with + | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 + | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 + | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) + | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 + | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 + | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 + | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 + | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 + | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 + | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 + | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 + | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 + end. + +(** Undefine all registers except SP and callee-save registers *) + +Definition undef_caller_save_regs (rs: regset) : regset := + fun r => + if preg_eq r SP + || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) + then rs r + else Vundef. + +(* FIXME: comment not up-to-date *) +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use RISC-V registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_stack: forall ofs ty bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv (chunk_of_type ty) m + (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> + extcall_arg rs m (S Outgoing ofs ty) v. + +Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := + | extcall_arg_one: forall l v, + extcall_arg rs m l v -> + extcall_arg_pair rs m (One l) v + | extcall_arg_twolong: forall hi lo vhi vlo, + extcall_arg rs m hi vhi -> + extcall_arg rs m lo vlo -> + extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. + + +Definition loc_external_result (sg: signature) : rpair preg := + map_rpair preg_of (loc_result sg). + + +(** Looking up bblocks in a code sequence by position. *) +Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := + match lb with + | nil => None + | b :: il => + if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) + else if zeq pos 0 then Some b + else find_bblock (pos - (size b)) il + end. + + +Inductive state: Type := + | State: regset -> mem -> state. + +Definition nextblock (b:bblock) (rs: regset) := + incrPC (Ptrofs.repr (size b)) rs. + +Inductive step: state -> trace -> state -> Prop := + | exec_step_internal: + forall b ofs f bundle rs m rs' m', + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + det_parexec f bundle rs m rs' m' -> + step (State rs m) E0 (State rs' m') + | exec_step_builtin: + forall b ofs f ef args res rs m vargs t vres rs' m' bi, + rs PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> + exit bi = Some (PExpand (Pbuiltin ef args res)) -> + eval_builtin_args ge rs (rs SP) m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = nextblock bi + (set_res res vres + (undef_regs (map preg_of (destroyed_by_builtin ef)) + (rs#RTMP <- Vundef))) -> + step (State rs m) t (State rs' m') + | exec_step_external: + forall b ef args res rs m t rs' m', + rs PC = Vptr b Ptrofs.zero -> + Genv.find_funct_ptr ge b = Some (External ef) -> + external_call ef ge args m t res m' -> + extcall_arguments rs m (ef_sig ef) args -> + rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> + step (State rs m) t (State rs' m') + . + + +(** parallel in-order writes execution of bundles *) +Definition parexec_wio_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome := + parexec_wio f (body b) (exit b) (Ptrofs.repr (size b)) rs m. + + +Lemma parexec_bblock_write_in_order f b rs m: + parexec_bblock f b rs m (parexec_wio_bblock f b rs m). +Proof. + exists (body b). exists nil. + constructor 1. + - rewrite app_nil_r; auto. + - unfold parexec_wio_bblock. + destruct (parexec_wio f _ _ _); simpl; auto. +Qed. + + +Local Hint Resolve parexec_bblock_write_in_order: core. + +Lemma det_parexec_write_in_order f b rs m rs' m': + det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'. +Proof. + unfold det_parexec; auto. +Qed. + +End RELSEM. + +(** Execution of whole programs. *) + +(** Execution of whole programs. *) + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall m0, + let ge := Genv.globalenv p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) + # SP <- Vnullptr + # RA <- Vnullptr in + Genv.init_mem p = Some m0 -> + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs PC = Vnullptr -> + rs GPR0 = Vint r -> + final_state (State rs m) r. + +Definition semantics (p: program) := + Semantics step (initial_state p) final_state (Genv.globalenv p). + +Remark extcall_arguments_determ: + forall rs m sg args1 args2, + extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. +Proof. + intros until m. + assert (A: forall l v1 v2, + extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). + { intros. inv H; inv H0; congruence. } + assert (B: forall p v1 v2, + extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). + { intros. inv H; inv H0. + eapply A; eauto. + f_equal; eapply A; eauto. } + assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> + forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). + { + induction 1; intros vl2 EA; inv EA. + auto. + f_equal; eauto. } + intros. eapply C; eauto. +Qed. + +Lemma semantics_determinate p: determinate (semantics p). +Proof. +Ltac Equalities := + match goal with + | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => + rewrite H1 in H2; inv H2; Equalities + | _ => idtac + end. +Ltac Det_WIO X := + match goal with + | [ H: det_parexec _ _ _ _ _ _ _ |- _ ] => + exploit det_parexec_write_in_order; [ eapply H | idtac]; clear H; intro X + | _ => idtac + end. + intros; constructor; simpl. +- (* determ *) intros s t1 s1 t2 s2 H H0. inv H; Det_WIO X1; + inv H0; Det_WIO X2; Equalities. + + split. constructor. auto. + + unfold parexec_wio_bblock, parexec_wio in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + rewrite H8 in X1. discriminate. + + unfold parexec_wio_bblock, parexec_wio in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. + rewrite H4 in X2. discriminate. + + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. + exploit external_call_determ. eexact H6. eexact H13. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. + + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. + exploit external_call_determ. eexact H3. eexact H8. intros [A B]. + split. auto. intros. destruct B; auto. subst. auto. +- (* trace length *) + red; intros. inv H; simpl. + omega. + eapply external_call_trace_length; eauto. + eapply external_call_trace_length; eauto. +- (* initial states *) + intros s1 s2 H H0; inv H; inv H0; f_equal; congruence. +- (* final no step *) + intros s r H; assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). + { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } + inv H. red; intros; red; intros. + inv H; rewrite H0 in *; eelim NOTNULL; eauto. +- (* final states *) + intros s r1 r2 H H0; inv H; inv H0. congruence. +Qed. diff --git a/kvx/Builtins1.v b/kvx/Builtins1.v new file mode 100644 index 00000000..eeb578d0 --- /dev/null +++ b/kvx/Builtins1.v @@ -0,0 +1,66 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Platform-specific built-in functions *) + +Require Import String Coqlib. +Require Import AST Integers Floats Values ExtFloats. +Require Import Builtins0. + +Inductive platform_builtin : Type := +| BI_fmin +| BI_fmax +| BI_fminf +| BI_fmaxf +| BI_fabsf +| BI_fma +| BI_fmaf. + +Local Open Scope string_scope. + +Definition platform_builtin_table : list (string * platform_builtin) := + ("__builtin_fmin", BI_fmin) + :: ("__builtin_fmax", BI_fmax) + :: ("__builtin_fminf", BI_fminf) + :: ("__builtin_fmaxf", BI_fmaxf) + :: ("__builtin_fabsf", BI_fabsf) + :: ("__builtin_fma", BI_fma) + :: ("__builtin_fmaf", BI_fmaf) + :: nil. + +Definition platform_builtin_sig (b: platform_builtin) : signature := + match b with + | BI_fmin | BI_fmax => + mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default + | BI_fminf | BI_fmaxf => + mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default + | BI_fabsf => + mksignature (Tsingle :: nil) Tsingle cc_default + | BI_fma => + mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default + | BI_fmaf => + mksignature (Tsingle :: Tsingle :: Tsingle :: nil) Tsingle cc_default + end. + +Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := + match b with + | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min + | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max + | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min + | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max + | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs + | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma + | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma + end. diff --git a/kvx/CBuiltins.ml b/kvx/CBuiltins.ml new file mode 100644 index 00000000..fa2f4c60 --- /dev/null +++ b/kvx/CBuiltins.ml @@ -0,0 +1,143 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(* Processor-dependent builtin C functions *) + +open C + +let builtins = { + builtin_typedefs = [ + "__builtin_va_list", TPtr(TVoid [], []) + ]; + (* The builtin list is inspired from the GCC file builtin_kvx.h *) + builtin_functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) + (* BCU Instructions *) + "__builtin_kvx_await", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_barrier", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_doze", (TVoid [], [], false); (* opcode not supported in assembly, not in documentation *) + "__builtin_kvx_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) + "__builtin_kvx_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) + "__builtin_kvx_sleep", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_stop", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_syncgroup", (TVoid [], [TInt(IULongLong, [])], false); + "__builtin_kvx_tlbread", (TVoid [], [], false); + "__builtin_kvx_tlbwrite", (TVoid [], [], false); + "__builtin_kvx_tlbprobe", (TVoid [], [], false); + "__builtin_kvx_tlbdinval", (TVoid [], [], false); + "__builtin_kvx_tlbiinval", (TVoid [], [], false); + + "__builtin_kvx_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); (* DONE *) + "__builtin_kvx_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) + + (* LSU Instructions *) + (* acswapd and acswapw done using headers and assembly *) +(* "__builtin_kvx_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); + "__builtin_kvx_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); *) (* see #157 *) + "__builtin_kvx_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_dinval", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_fence", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_iinval", (TVoid [], [], false); (* DONE *) + "__builtin_kvx_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE [not supported by assembler but in documentation] *) + "__builtin_kvx_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); + "__builtin_kvx_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); + "__builtin_kvx_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) + "__builtin_kvx_lhsu", (TInt(IShort, []), [TPtr(TVoid [], [])], false); + "__builtin_kvx_lhzu", (TInt(IUShort, []), [TPtr(TVoid [], [])], false); + "__builtin_kvx_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); + + (* ALU Instructions *) + (* "__builtin_kvx_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_kvx_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_kvx_bwlu", (TInt(IUInt, []), + [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUShort, [])], false); *) + (* "__builtin_kvx_bwluhp", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_kvx_bwluwp", (TInt(IULongLong, []), + [TInt(IULongLong, []); TInt(IULongLong, []); TInt(IUInt, [])], false); *) + (* "__builtin_kvx_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + (* "__builtin_kvx_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_kvx_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + (* "__builtin_kvx_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_kvx_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_kvx_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) + "__builtin_kvx_ctzw", (TInt(IInt, []), [TInt(IUInt, [])], false); + "__builtin_kvx_ctzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); + (* "__builtin_kvx_ctzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) + (* "__builtin_kvx_extfz", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_kvx_landhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) + (* "__builtin_kvx_sat", (TInt(IInt, []), [TInt(IInt, []); TInt(IUChar, [])], false); *) + "__builtin_kvx_satd", (TInt(ILongLong, []), [TInt(ILongLong, []); TInt(IUChar, [])], false); + (* "__builtin_kvx_sbfhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) + "__builtin_kvx_sbmm8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + "__builtin_kvx_sbmmt8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + (* "__builtin_kvx_sllhps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_kvx_srahps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + (* "__builtin_kvx_stsu", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) + "__builtin_kvx_stsud", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); + + + (* Synchronization *) +(* "__builtin_fence", + (TVoid [], [], false); *) +(* (* Float arithmetic *) + "__builtin_fmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fnmadd", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fnmsub", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) + "__builtin_fabsf", + (TFloat(FFloat, []), + [TFloat(FFloat, [])], false); + "__builtin_fmax", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmin", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmaxf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fminf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, [])], false); + "__builtin_fma", + (TFloat(FDouble, []), + [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); + "__builtin_fmaf", + (TFloat(FFloat, []), + [TFloat(FFloat, []); TFloat(FFloat, []); TFloat(FFloat, [])], false); +] +} + +let va_list_type = TPtr(TVoid [], []) (* to check! *) +let size_va_list = if Archi.ptr64 then 8 else 4 +let va_list_scalar = true + +(* Expand memory references inside extended asm statements. Used in C2C. *) + +let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/kvx/CSE2deps.v b/kvx/CSE2deps.v new file mode 100644 index 00000000..b4b80e2f --- /dev/null +++ b/kvx/CSE2deps.v @@ -0,0 +1,32 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs Events. +Require Import Op. + + +Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := + (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) + && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) + && ((ofsw + size_chunk chunkw <=? ofsr) || + (ofsr + size_chunk chunkr <=? ofsw)). + +Definition may_overlap chunk addr args chunk' addr' args' := + match addr, addr', args, args' with + | (Aindexed ofs), (Aindexed ofs'), + (base :: nil), (base' :: nil) => + if peq base base' + then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) + else true | _, _, _, _ => true + end. diff --git a/kvx/CSE2depsproof.v b/kvx/CSE2depsproof.v new file mode 100644 index 00000000..f283c8ac --- /dev/null +++ b/kvx/CSE2depsproof.v @@ -0,0 +1,139 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* David Monniaux CNRS, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL Maps. + +Require Import Globalenvs Values. +Require Import Linking Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import CSE2 CSE2deps. +Require Import Lia. + +Lemma ptrofs_size : + Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat. +Proof. + unfold Ptrofs.wordsize. + unfold Wordsize_Ptrofs.wordsize. + trivial. +Qed. + +Lemma ptrofs_modulus : + Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. +Proof. + unfold Ptrofs.modulus. + rewrite ptrofs_size. + destruct Archi.ptr64; reflexivity. +Qed. + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Section MEMORY_WRITE. + Variable m m2 : mem. + Variable chunkw chunkr : memory_chunk. + Variable base : val. + + Variable addrw addrr valw : val. + Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. + + Section INDEXED_AWAY. + Variable ofsw ofsr : ptrofs. + Hypothesis ADDRW : eval_addressing genv sp + (Aindexed ofsw) (base :: nil) = Some addrw. + Hypothesis ADDRR : eval_addressing genv sp + (Aindexed ofsr) (base :: nil) = Some addrr. + + Lemma load_store_away1 : + forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, + forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, + forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr + \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + + Proof. + intros. + + pose proof (max_size_chunk chunkr) as size_chunkr_bounded. + pose proof (max_size_chunk chunkw) as size_chunkw_bounded. + unfold largest_size_chunk in *. + + rewrite ptrofs_modulus in *. + simpl in *. + inv ADDRR. + inv ADDRW. + destruct base; try discriminate. + eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). + exact STORE. + right. + + all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; + rewrite OFSR). + all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; + rewrite OFSW). + all: try rewrite ptrofs_modulus in *. + all: destruct Archi.ptr64. + + all: intuition lia. + Qed. + + Theorem load_store_away : + can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> + Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. + Proof. + intro SWAP. + unfold can_swap_accesses_ofs in SWAP. + repeat rewrite andb_true_iff in SWAP. + repeat rewrite orb_true_iff in SWAP. + repeat rewrite Z.leb_le in SWAP. + apply load_store_away1. + all: tauto. + Qed. + End INDEXED_AWAY. +End MEMORY_WRITE. +End SOUNDNESS. + + +Section SOUNDNESS. + Variable F V : Type. + Variable genv: Genv.t F V. + Variable sp : val. + +Lemma may_overlap_sound: + forall m m' : mem, + forall chunk addr args chunk' addr' args' v a a' rs, + (eval_addressing genv sp addr (rs ## args)) = Some a -> + (eval_addressing genv sp addr' (rs ## args')) = Some a' -> + (may_overlap chunk addr args chunk' addr' args') = false -> + (Mem.storev chunk m a v) = Some m' -> + (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). +Proof. + intros until rs. + intros ADDR ADDR' OVERLAP STORE. + destruct addr; destruct addr'; try discriminate. + { (* Aindexed / Aindexed *) + destruct args as [ | base [ | ]]. 1,3: discriminate. + destruct args' as [ | base' [ | ]]. 1,3: discriminate. + simpl in OVERLAP. + destruct (peq base base'). 2: discriminate. + subst base'. + destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. + 2: discriminate. + simpl in *. + eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. + } +Qed. + +End SOUNDNESS. diff --git a/kvx/Chunks.v b/kvx/Chunks.v new file mode 100644 index 00000000..86d4f0ac --- /dev/null +++ b/kvx/Chunks.v @@ -0,0 +1,36 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import AST. +Require Import Values. +Require Import Integers. +Require Import Coq.ZArith.BinIntDef. +Require Import BinNums. + +Local Open Scope Z_scope. + +Definition zscale_of_chunk (chunk: memory_chunk) : Z := + match chunk with + | Mint8signed => 0 + | Mint8unsigned => 0 + | Mint16signed => 1 + | Mint16unsigned => 1 + | Mint32 => 2 + | Mint64 => 3 + | Mfloat32 => 2 + | Mfloat64 => 3 + | Many32 => 2 + | Many64 => 3 + end. +Definition scale_of_chunk chunk := Vint (Int.repr (zscale_of_chunk chunk)). diff --git a/kvx/CombineOp.v b/kvx/CombineOp.v new file mode 100644 index 00000000..ff1db3cd --- /dev/null +++ b/kvx/CombineOp.v @@ -0,0 +1,141 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Op. +Require Import CSEdomain. + +Section COMBINE. + +Variable get: valnum -> option rhs. + +Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (c, ys) + | _ => None + end. + +Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) := + match get x with + | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) + | _ => None + end. + +Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) := + match cond, args with + | Ccompimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | Ccompuimm Cne n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_ne_0 x + else if Int.eq_dec n Int.one then combine_compimm_ne_1 x + else None + | Ccompuimm Ceq n, x::nil => + if Int.eq_dec n Int.zero then combine_compimm_eq_0 x + else if Int.eq_dec n Int.one then combine_compimm_eq_1 x + else None + | _, _ => None + end. + +Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := + match addr, args with + | Aindexed n, x::nil => + match get x with + | Some(Op (Oaddimm m) ys) => + if Archi.ptr64 then None else Some(Aindexed (Ptrofs.add (Ptrofs.of_int m) n), ys) + | Some(Op (Oaddlimm m) ys) => + if Archi.ptr64 then Some(Aindexed (Ptrofs.add (Ptrofs.of_int64 m) n), ys) else None + | _ => None + end + | _, _ => None + end. + +Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) := + match op, args with + | Oaddimm n, x :: nil => + match get x with + | Some(Op (Oaddimm m) ys) => Some(Oaddimm (Int.add m n), ys) + | _ => None + end + | Oandimm n, x :: nil => + match get x with + | Some(Op (Oandimm m) ys) => + Some(let p := Int.and m n in + if Int.eq p m then (Omove, x :: nil) else (Oandimm p, ys)) + | _ => None + end + | Oorimm n, x :: nil => + match get x with + | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys) + | _ => None + end + | Oxorimm n, x :: nil => + match get x with + | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys) + | _ => None + end + | Oaddlimm n, x :: nil => + match get x with + | Some(Op (Oaddlimm m) ys) => Some(Oaddlimm (Int64.add m n), ys) + | _ => None + end + | Oandlimm n, x :: nil => + match get x with + | Some(Op (Oandlimm m) ys) => + Some(let p := Int64.and m n in + if Int64.eq p m then (Omove, x :: nil) else (Oandlimm p, ys)) + | _ => None + end + | Oorlimm n, x :: nil => + match get x with + | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys) + | _ => None + end + | Oxorlimm n, x :: nil => + match get x with + | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys) + | _ => None + end + | Ocmp cond, _ => + match combine_cond cond args with + | Some(cond', args') => Some(Ocmp cond', args') + | None => None + end + | _, _ => None + end. + +End COMBINE. diff --git a/kvx/CombineOpproof.v b/kvx/CombineOpproof.v new file mode 100644 index 00000000..dafc90df --- /dev/null +++ b/kvx/CombineOpproof.v @@ -0,0 +1,176 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Recognition of combined operations, addressing modes and conditions + during the [CSE] phase. *) + +Require Import FunInd. +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import CSEdomain. +Require Import CombineOp. + +Section COMBINE. + +Variable ge: genv. +Variable sp: val. +Variable m: mem. +Variable get: valnum -> option rhs. +Variable valu: valnum -> val. +Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v). + +Lemma get_op_sound: + forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v). +Proof. + intros. exploit get_sound; eauto. intros REV; inv REV; auto. +Qed. + +Ltac UseGetSound := + match goal with + | [ H: get _ = Some _ |- _ ] => + let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv) + end. + +Lemma combine_compimm_ne_0_sound: + forall x cond args, + combine_compimm_ne_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_0_sound: + forall x cond args, + combine_compimm_eq_0 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero). +Proof. + intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_eq_1_sound: + forall x cond args, + combine_compimm_eq_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Lemma combine_compimm_ne_1_sound: + forall x cond args, + combine_compimm_ne_1 get x = Some(cond, args) -> + eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\ + eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one). +Proof. + intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ. + (* of cmp *) + UseGetSound. rewrite <- H. + rewrite eval_negate_condition. + destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. +Qed. + +Theorem combine_cond_sound: + forall cond args cond' args', + combine_cond get cond args = Some(cond', args') -> + eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* compimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. + (* compuimm ne zero *) + - simpl; eapply combine_compimm_ne_0_sound; eauto. + (* compuimm ne one *) + - simpl; eapply combine_compimm_ne_1_sound; eauto. + (* compuimm eq zero *) + - simpl; eapply combine_compimm_eq_0_sound; eauto. + (* compuimm eq one *) + - simpl; eapply combine_compimm_eq_1_sound; eauto. +Qed. + +Theorem combine_addr_sound: + forall addr args addr' args', + combine_addr get addr args = Some(addr', args') -> + eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). +Proof. + intros. functional inversion H; subst. +- (* indexed - addimm *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +- (* indexed - addimml *) + UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. + rewrite Ptrofs.add_assoc. auto. +Qed. + +Theorem combine_op_sound: + forall op args op' args', + combine_op get op args = Some(op', args') -> + eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m. +Proof. + intros. functional inversion H; subst. + (* addimm - addimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.add_assoc. auto. + (* andimm - andimm *) + - UseGetSound; simpl. + generalize (Int.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.and_assoc. auto. + (* orimm - orimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto. + (* xorimm - xorimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. + (* addlimm - addlimm *) + - UseGetSound. FuncInv. simpl. + rewrite <- H0. rewrite Val.addl_assoc. auto. + (* andlimm - andlimm *) + - UseGetSound; simpl. + generalize (Int64.eq_spec p m0); rewrite H7; intros. + rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto. + - UseGetSound; simpl. + rewrite <- H0. rewrite Val.andl_assoc. auto. + (* orlimm - orlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. + (* xorlimm - xorlimm *) + - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. + (* cmp *) + - simpl. decEq; decEq. eapply combine_cond_sound; eauto. +Qed. + +End COMBINE. diff --git a/kvx/ConstpropOp.vp b/kvx/ConstpropOp.vp new file mode 100644 index 00000000..2a428020 --- /dev/null +++ b/kvx/ConstpropOp.vp @@ -0,0 +1,312 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Strength reduction for operators and conditions. + This is the machine-dependent part of [Constprop]. *) + +Require Archi. +Require Import Coqlib Compopts. +Require Import AST Integers Floats. +Require Import Op Registers. +Require Import ValueDomain. + +(** * Converting known values to constants *) + +Definition const_for_result (a: aval) : option operation := + match a with + | I n => Some(Ointconst n) + | L n => if Archi.ptr64 then Some(Olongconst n) else None + | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None + | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None + | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) + | Ptr(Stk ofs) => Some(Oaddrstack ofs) + | _ => None + end. + +(** * Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Nondetfunction cond_strength_reduction + (cond: condition) (args: list reg) (vl: list aval) := + match cond, args, vl with + | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompimm (swap_comparison c) n1, r2 :: nil) + | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompimm c n2, r1 :: nil) + | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => + (Ccompuimm (swap_comparison c) n1, r2 :: nil) + | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => + (Ccompuimm c n2, r1 :: nil) + | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccomplimm (swap_comparison c) n1, r2 :: nil) + | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccomplimm c n2, r1 :: nil) + | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => + (Ccompluimm (swap_comparison c) n1, r2 :: nil) + | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => + (Ccompluimm c n2, r1 :: nil) + | _, _, _ => + (cond, args) + end. + +Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := + let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). + +Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) + (n: int) (r1: reg) (v1: aval) := + if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) + else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) + else make_cmp_base c args vl. + +Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := + match c, args, vl with + | Ccompimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => + make_cmp_imm_eq c args vl n r1 v1 + | Ccompuimm Cne n, r1 :: nil, v1 :: nil => + make_cmp_imm_ne c args vl n r1 v1 + | _, _, _ => + make_cmp_base c args vl + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) + else (Oshl, r1 :: r2 :: nil). + +Definition make_shrimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) + else (Oshr, r1 :: r2 :: nil). + +Definition make_shruimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) + else (Oshru, r1 :: r2 :: nil). + +Definition make_mulimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshlimm l, r1 :: nil) + | None => (Omul, r1 :: r2 :: nil) + end. + +Definition make_andimm (n: int) (r: reg) (a: aval) := + if Int.eq n Int.zero then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero + | _ => false end + then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Definition make_divimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => if Int.ltu l (Int.repr 31) + then (Oshrximm l, r1 :: nil) + else (Odiv, r1 :: r2 :: nil) + | None => (Odiv, r1 :: r2 :: nil) + end. + +Definition make_divuimm n (r1 r2: reg) := + if Int.eq n Int.one then + (Omove, r1 :: nil) + else + match Int.is_power2 n with + | Some l => (Oshruimm l, r1 :: nil) + | None => (Odivu, r1 :: r2 :: nil) + end. + +Definition make_moduimm n (r1 r2: reg) := + match Int.is_power2 n with + | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) + | None => (Omodu, r1 :: r2 :: nil) + end. + +Definition make_addlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero + then (Omove, r :: nil) + else (Oaddlimm n, r :: nil). + +Definition make_shllimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) + else (Oshll, r1 :: r2 :: nil). + +Definition make_shrlimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) + else (Oshrl, r1 :: r2 :: nil). + +Definition make_shrluimm (n: int) (r1 r2: reg) := + if Int.eq n Int.zero then (Omove, r1 :: nil) + else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) + else (Oshrlu, r1 :: r2 :: nil). + +Definition make_mullimm (n: int64) (r1 r2: reg) := + if Int64.eq n Int64.zero then + (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.one then + (Omove, r1 :: nil) + else + match Int64.is_power2' n with + | Some l => (Oshllimm l, r1 :: nil) + | None => (Omull, r1 :: r2 :: nil) + end. + +Definition make_andlimm (n: int64) (r: reg) (a: aval) := + if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) + else if Int64.eq n Int64.mone then (Omove, r :: nil) + else (Oandlimm n, r :: nil). + +Definition make_orlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) + else (Oorlimm n, r :: nil). + +Definition make_xorlimm (n: int64) (r: reg) := + if Int64.eq n Int64.zero then (Omove, r :: nil) + else (Oxorlimm n, r :: nil). + +Definition make_divlimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => if Int.ltu l (Int.repr 63) + then (Oshrxlimm l, r1 :: nil) + else (Odivl, r1 :: r2 :: nil) + | None => (Odivl, r1 :: r2 :: nil) + end. + +Definition make_divluimm n (r1 r2: reg) := + match Int64.is_power2' n with + | Some l => (Oshrluimm l, r1 :: nil) + | None => (Odivlu, r1 :: r2 :: nil) + end. + +Definition make_modluimm n (r1 r2: reg) := + match Int64.is_power2 n with + | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) + | None => (Omodlu, r1 :: r2 :: nil) + end. + +Definition make_mulfimm (n: float) (r r1 r2: reg) := + if Float.eq_dec n (Float.of_int (Int.repr 2)) + then (Oaddf, r :: r :: nil) + else (Omulf, r1 :: r2 :: nil). + +Definition make_mulfsimm (n: float32) (r r1 r2: reg) := + if Float32.eq_dec n (Float32.of_int (Int.repr 2)) + then (Oaddfs, r :: r :: nil) + else (Omulfs, r1 :: r2 :: nil). + +Definition make_cast8signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). +Definition make_cast16signed (r: reg) (a: aval) := + if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). + +Nondetfunction op_strength_reduction + (op: operation) (args: list reg) (vl: list aval) := + match op, args, vl with + | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 + | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 + | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 + | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 + | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 + | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 + | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 + | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 + | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 + | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 + | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 + | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 + | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 + | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 + | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 + | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 + | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 + | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 + | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 + | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 + | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 + | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 + | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 + | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 + | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 + | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 + | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 + | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 + | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 + | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 + | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 + | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 + | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 + | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 + | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 + | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 + | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 + | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 + | Ocmp c, args, vl => make_cmp c args vl + | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 + | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 + | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 + | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 + | _, _, _ => (op, args) + end. + +Nondetfunction addr_strength_reduction + (addr: addressing) (args: list reg) (vl: list aval) := + match addr, args, vl with + | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => + if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) + then (addr, args) + else (Aglobal symb (Ptrofs.add n1 n), nil) + | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => + (Ainstack (Ptrofs.add n1 n), nil) + | _, _, _ => + (addr, args) + end. + diff --git a/kvx/ConstpropOpproof.v b/kvx/ConstpropOpproof.v new file mode 100644 index 00000000..05bbdde1 --- /dev/null +++ b/kvx/ConstpropOpproof.v @@ -0,0 +1,748 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Correctness proof for operator strength reduction. *) + +Require Import Coqlib Compopts. +Require Import Integers Floats Values Memory Globalenvs Events. +Require Import Op Registers RTL ValueDomain. +Require Import ConstpropOp. + +Section STRENGTH_REDUCTION. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. +Variable ae: AE.t. +Variable e: regset. +Variable m: mem. +Hypothesis MATCH: ematch bc e ae. + +Lemma match_G: + forall r id ofs, + AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). +Proof. + intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Lemma match_S: + forall r ofs, + AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). +Proof. + intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. +Qed. + +Ltac InvApproxRegs := + match goal with + | [ H: _ :: _ = _ :: _ |- _ ] => + injection H; clear H; intros; InvApproxRegs + | [ H: ?v = AE.get ?r ae |- _ ] => + generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs + | _ => idtac + end. + +Ltac SimplVM := + match goal with + | [ H: vmatch _ ?v (I ?n) |- _ ] => + let E := fresh in + assert (E: v = Vint n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (L ?n) |- _ ] => + let E := fresh in + assert (E: v = Vlong n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (F ?n) |- _ ] => + let E := fresh in + assert (E: v = Vfloat n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (FS ?n) |- _ ] => + let E := fresh in + assert (E: v = Vsingle n) by (inversion H; auto); + rewrite E in *; clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); + clear H; SimplVM + | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => + let E := fresh in + assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); + clear H; SimplVM + | _ => idtac + end. + +Lemma const_for_result_correct: + forall a op v, + const_for_result a = Some op -> + vmatch bc v a -> + exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. +Proof. + unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros. + destruct a; inv H; SimplVM. +- (* integer *) + exists (Vint n); auto. +- (* long *) + destruct ptr64; inv H2. exists (Vlong n); auto. +- (* float *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto. +- (* single *) + destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto. +- (* pointer *) + destruct p; try discriminate; SimplVM. + + (* global *) + inv H2. exists (Genv.symbol_address ge id ofs); auto. + + (* stack *) + inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args vl, + vl = map (fun r => AE.get r ae) args -> + let (cond', args') := cond_strength_reduction cond args vl in + eval_condition cond' e##args' m = eval_condition cond e##args m. +Proof. + intros until vl. unfold cond_strength_reduction. + case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. +- apply Val.swap_cmp_bool. +- auto. +- apply Val.swap_cmpu_bool. +- auto. +- apply Val.swap_cmpl_bool. +- auto. +- apply Val.swap_cmplu_bool. +- auto. +- auto. +Qed. + +Lemma make_cmp_base_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp_base c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros. unfold make_cmp_base. + generalize (cond_strength_reduction_correct c args vl H). + destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. + econstructor; split. simpl; eauto. rewrite EQ. auto. +Qed. + +Lemma make_cmp_correct: + forall c args vl, + vl = map (fun r => AE.get r ae) args -> + let (op', args') := make_cmp c args vl in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v + /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. +Proof. + intros c args vl. + assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> + e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). + { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } + unfold make_cmp. case (make_cmp_match c args vl); intros. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_eq. + destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- unfold make_cmp_imm_ne. + destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. ++ simpl in H; inv H. InvBooleans. subst n. + exists (e#r1); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. ++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. +* simpl in H; inv H. InvBooleans. subst n. + exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. + exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. +* apply make_cmp_base_correct; auto. +- apply make_cmp_base_correct; auto. +Qed. + +Lemma make_addimm_correct: + forall n r, + let (op, args) := make_addimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. +Proof. + intros. unfold make_addimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. + exists (Val.add e#r (Vint n)); split; auto. +Qed. + +Lemma make_shlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shruimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shruimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. +Proof. + intros; unfold make_shruimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. + destruct (Int.ltu n Int.iwordsize). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mulimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_mulimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. +Proof. + intros; unfold make_mulimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. + destruct (Int.is_power2 n) eqn:?; intros. + rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. + econstructor; split; eauto. simpl. rewrite H; auto. +Qed. + +Lemma make_divimm_correct: + forall n r1 r2 v, + Val.divs e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + destruct (Int.ltu i (Int.repr 31)) eqn:?. + exists v; split; auto. simpl. + erewrite Val.divs_pow2; eauto. reflexivity. congruence. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divuimm_correct: + forall n r1 r2 v, + Val.divu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_divuimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divuimm. + predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. + destruct (e#r1) eqn:?; + try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); + inv H; auto. + destruct (Int.is_power2 n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. + exists v; auto. +Qed. + +Lemma make_moduimm_correct: + forall n r1 r2 v, + Val.modu e#r1 e#r2 = Some v -> + e#r2 = Vint n -> + let (op, args) := make_moduimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_moduimm. + destruct (Int.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. + exists v; auto. +Qed. + +Lemma make_andimm_correct: + forall n r x, + vmatch bc e#r x -> + let (op, args) := make_andimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. +Proof. + intros; unfold make_andimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. + destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero + | _ => false end) eqn:UNS. + destruct x; try congruence. + exists (e#r); split; auto. + inv H; auto. simpl. replace (Int.and i n) with i; auto. + generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. + Int.bit_solve. destruct (zlt i0 n0). + replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). + rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. + rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. + rewrite Int.bits_not by auto. apply negb_involutive. + rewrite H6 by auto. auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orimm_correct: + forall n r, + let (op, args) := make_orimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. +Proof. + intros; unfold make_orimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorimm_correct: + forall n r, + let (op, args) := make_xorimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. +Proof. + intros; unfold make_xorimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. + predSpec Int.eq Int.eq_spec n Int.mone; intros. + subst n. exists (Val.notint e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_addlimm_correct: + forall n r, + let (op, args) := make_addlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. +Proof. + intros. unfold make_addlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst. exists (e#r); split; auto. + destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. + exists (Val.addl e#r (Vlong n)); split; auto. +Qed. + +Lemma make_shllimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shllimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v. +Proof. + intros; unfold make_shllimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrlimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrlimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrlimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_shrluimm_correct: + forall n r1 r2, + e#r2 = Vint n -> + let (op, args) := make_shrluimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v. +Proof. + intros; unfold make_shrluimm. + predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. + unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto. + destruct (Int.ltu n Int64.iwordsize'). + econstructor; split. simpl. eauto. auto. + econstructor; split. simpl. eauto. rewrite H; auto. +Qed. + +Lemma make_mullimm_correct: + forall n r1 r2, + e#r2 = Vlong n -> + let (op, args) := make_mullimm n r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v. +Proof. + intros; unfold make_mullimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. + exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst. + exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto. + destruct (Int64.is_power2' n) eqn:?; intros. + exists (Val.shll e#r1 (Vint i)); split; auto. + destruct (e#r1); simpl; auto. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.mul_pow2' by eauto. auto. + econstructor; split; eauto. simpl; rewrite H; auto. +Qed. + +Lemma make_divlimm_correct: + forall n r1 r2 v, + Val.divls e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divlimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divlimm. + destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. + rewrite H0 in H. econstructor; split. simpl; eauto. + erewrite Val.divls_pow2; eauto. auto. + exists v; auto. + exists v; auto. +Qed. + +Lemma make_divluimm_correct: + forall n r1 r2 v, + Val.divlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_divluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_divluimm. + destruct (Int64.is_power2' n) eqn:?. + econstructor; split. simpl; eauto. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. + erewrite Int64.is_power2'_range by eauto. + erewrite Int64.divu_pow2' by eauto. auto. + exists v; auto. +Qed. + +Lemma make_modluimm_correct: + forall n r1 r2 v, + Val.modlu e#r1 e#r2 = Some v -> + e#r2 = Vlong n -> + let (op, args) := make_modluimm n r1 r2 in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. +Proof. + intros; unfold make_modluimm. + destruct (Int64.is_power2 n) eqn:?. + exists v; split; auto. simpl. decEq. + rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. + simpl. erewrite Int64.modu_and by eauto. auto. + exists v; auto. +Qed. + +Lemma make_andlimm_correct: + forall n r x, + let (op, args) := make_andlimm n r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v. +Proof. + intros; unfold make_andlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_orlimm_correct: + forall n r, + let (op, args) := make_orlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v. +Proof. + intros; unfold make_orlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_xorlimm_correct: + forall n r, + let (op, args) := make_xorlimm n r in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v. +Proof. + intros; unfold make_xorlimm. + predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. + subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. + subst n. exists (Val.notl e#r); split; auto. + econstructor; split; eauto. auto. +Qed. + +Lemma make_mulfimm_correct: + forall n r1 r2, + e#r2 = Vfloat n -> + let (op, args) := make_mulfimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfimm_correct_2: + forall n r1 r2, + e#r1 = Vfloat n -> + let (op, args) := make_mulfimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. +Proof. + intros; unfold make_mulfimm. + destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. + rewrite Float.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct: + forall n r1 r2, + e#r2 = Vsingle n -> + let (op, args) := make_mulfsimm n r1 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_mulfsimm_correct_2: + forall n r1 r2, + e#r1 = Vsingle n -> + let (op, args) := make_mulfsimm n r2 r1 r2 in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. +Proof. + intros; unfold make_mulfsimm. + destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. + simpl. econstructor; split. eauto. rewrite H; subst n. + destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. + rewrite Float32.mul_commut; auto. + simpl. econstructor; split; eauto. +Qed. + +Lemma make_cast8signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast8signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. +Proof. + intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 8)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma make_cast16signed_correct: + forall r x, + vmatch bc e#r x -> + let (op, args) := make_cast16signed r x in + exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. +Proof. + intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. + exists e#r; split; auto. + assert (V: vmatch bc e#r (Sgn Ptop 16)). + { eapply vmatch_ge; eauto. apply vincl_ge; auto. } + inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. + econstructor; split; simpl; eauto. +Qed. + +Lemma op_strength_reduction_correct: + forall op args vl v, + vl = map (fun r => AE.get r ae) args -> + eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v -> + let (op', args') := op_strength_reduction op args vl in + exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w. +Proof. + intros until v; unfold op_strength_reduction; + case (op_strength_reduction_match op args vl); simpl; intros. +- (* cast8signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. +- (* cast16signed *) + InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. +- (* add 1 *) + rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* add 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. +- (* sub *) + InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. +- (* mul 1 *) + rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* mul 2*) + InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. +- (* divs *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divimm_correct; auto. +- (* divu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divuimm_correct; auto. +- (* modu *) + assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_moduimm_correct; auto. +- (* and 1 *) + rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* and 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. +- (* andimm *) + inv H; inv H0. apply make_andimm_correct; auto. +- (* or 1 *) + rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* or 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. +- (* xor 1 *) + rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* xor 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. +- (* shl *) + InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. +- (* shr *) + InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. +- (* shru *) + InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. +- (* addl 1 *) + rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* addl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. +- (* subl *) + InvApproxRegs; SimplVM; inv H0. + replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))). + apply make_addlimm_correct; auto. + unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto. + rewrite Int64.sub_add_opp; auto. + rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. + rewrite Int64.sub_add_opp; auto. +- (* mull 1 *) + rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* mull 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. +- (* divl *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divlimm_correct; auto. +- (* divlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_divluimm_correct; auto. +- (* modlu *) + assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. + apply make_modluimm_correct; auto. +- (* andl 1 *) + rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. +- (* andlimm *) + inv H; inv H0. apply make_andlimm_correct; auto. +- (* orl 1 *) + rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* orl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. +- (* xorl 1 *) + rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* xorl 2 *) + InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. +- (* shll *) + InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. +- (* shrl *) + InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. +- (* shrlu *) + InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. +- (* cond *) + inv H0. apply make_cmp_correct; auto. +- (* mulf 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. +- (* mulf 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). + rewrite <- H2. apply make_mulfimm_correct_2; auto. +- (* mulfs 1 *) + InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. +- (* mulfs 2 *) + InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). + rewrite <- H2. apply make_mulfsimm_correct_2; auto. +- (* default *) + exists v; auto. +Qed. + +Lemma addr_strength_reduction_correct: + forall addr args vl res, + vl = map (fun r => AE.get r ae) args -> + eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> + let (addr', args') := addr_strength_reduction addr args vl in + exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. +Proof. + intros until res. unfold addr_strength_reduction. + destruct (addr_strength_reduction_match addr args vl); simpl; + intros VL EA; InvApproxRegs; SimplVM; try (inv EA). +- destruct (orb _ _). ++ exists (Val.offset_ptr e#r1 n); auto. ++ simpl. rewrite Genv.shift_symbol_address. econstructor; split; eauto. + inv H0; simpl; auto. +- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. + change (Vptr sp (Ptrofs.add n1 n)) with (Val.offset_ptr (Vptr sp n1) n). + inv H0; simpl; auto. +- exists res; auto. +Qed. + +End STRENGTH_REDUCTION. diff --git a/kvx/Conventions1.v b/kvx/Conventions1.v new file mode 100644 index 00000000..ab30ded9 --- /dev/null +++ b/kvx/Conventions1.v @@ -0,0 +1,418 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib Decidableplus. +Require Import AST Machregs Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Callee-save registers, whose value is preserved across a function call. +- Caller-save registers that can be modified during a function call. + + We follow the RISC-V application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition is_callee_save (r: mreg) : bool := + match r with + (* | R15 | R16 | R17 *) | R18 | R19 | R20 | R21 | R22 + | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true + | _ => false + end. + +Definition int_caller_save_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R10 :: R11 :: R15 (* :: R16 *) :: R17 + (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 + :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 + :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 + :: R62 :: R63 :: nil. + +Definition float_caller_save_regs : list mreg := nil. + +Definition int_callee_save_regs := + (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 + :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. + +Definition float_callee_save_regs : list mreg := nil. + +Definition destroyed_at_call := + List.filter (fun r => negb (is_callee_save r)) all_mregs. + +Definition dummy_int_reg := R63. (**r Used in [Coloring]. *) +Definition dummy_float_reg := R62. (**r Used in [Coloring]. *) + +Definition callee_save_type := mreg_type. + +Definition is_float_reg (r: mreg) := false. + +(** * Function calling conventions *) + +(** The functions in this section determine the locations (machine registers + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another compiler, we + implement the standard RISC-V conventions. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R10] or [F10] or [R10,R11], depending on the type of the + returned value. We treat a function without result as a function + with one integer result. *) + + +Definition loc_result (s: signature) : rpair mreg := + match s.(sig_res) with + | Tvoid => One R0 + | Tint8signed => One R0 + | Tint8unsigned => One R0 + | Tint16signed => One R0 + | Tint16unsigned => One R0 + | Tint | Tany32 => One R0 + | Tfloat | Tsingle | Tany64 => One R0 + | Tlong => if Archi.ptr64 then One R0 else One R0 + end. + +(** The result registers have types compatible with that given in the signature. *) + +Lemma loc_result_type: + forall sig, + subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. +Proof. + intros. unfold proj_sig_res, loc_result, mreg_type. + destruct (sig_res sig); try destruct Archi.ptr64; simpl; trivial; destruct t; trivial. +Qed. + +(** The result locations are caller-save registers *) + +Lemma loc_result_caller_save: + forall (s: signature), + forall_rpair (fun r => is_callee_save r = false) (loc_result s). +Proof. + intros. unfold loc_result, is_callee_save; + destruct (sig_res s); simpl; auto; try destruct Archi.ptr64; simpl; auto; try destruct t; simpl; auto. +Qed. + +(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) + +Lemma loc_result_pair: + forall sg, + match loc_result sg with + | One _ => True + | Twolong r1 r2 => + r1 <> r2 /\ proj_sig_res sg = Tlong + /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true + /\ Archi.ptr64 = false + end. +Proof. + intros. + unfold loc_result; destruct (sig_res sg); auto; + unfold mreg_type; try destruct Archi.ptr64; auto; + destruct t; auto. +Qed. + +(** The location of the result depends only on the result part of the signature *) + +Lemma loc_result_exten: + forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. +Proof. + intros. unfold loc_result. rewrite H; auto. +Qed. + +(** ** Location of function arguments *) + +(** The RISC-V ABI states the following convention for passing arguments + to a function: + +- Arguments are passed in registers when possible. + +- Up to eight integer registers (ai: int_param_regs) and up to eight + floating-point registers (fai: float_param_regs) are used for this + purpose. + +- If the arguments to a function are conceptualized as fields of a C + struct, each with pointer alignment, the argument registers are a + shadow of the first eight pointer-words of that struct. If argument + i < 8 is a floating-point type, it is passed in floating-point + register fa_i; otherwise, it is passed in integer register a_i. + +- When primitive arguments twice the size of a pointer-word are passed + on the stack, they are naturally aligned. When they are passed in the + integer registers, they reside in an aligned even-odd register pair, + with the even register holding the least-significant bits. + +- Floating-point arguments to variadic functions (except those that + are explicitly named in the parameter list) are passed in integer + registers. + +- The portion of the conceptual struct that is not passed in argument + registers is passed on the stack. The stack pointer sp points to the + first argument not passed in a register. + +The bit about variadic functions doesn't quite fit CompCert's model. +We do our best by passing the FP arguments in registers, as usual, +and reserving the corresponding integer registers, so that fixup +code can be introduced in the Asmexpand pass. +*) + +Definition param_regs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: nil. + +Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + match list_nth_z regs rn with + | Some r => + One(R r) :: rec (rn + 1) ofs + | None => + let ofs := align ofs (typealign ty) in + One(S Outgoing ofs ty) :: rec rn (ofs + (if Archi.ptr64 then 2 else typesize ty)) + end. + +Definition two_args (regs: list mreg) (rn: Z) (ofs: Z) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn, list_nth_z regs (rn + 1) with + | Some r1, Some r2 => + Twolong (R r2) (R r1) :: rec (rn + 2) ofs + | _, _ => + let ofs := align ofs 2 in + Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) :: + rec rn (ofs + 2) + end. + +Definition hybrid_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) + (rec: Z -> Z -> list (rpair loc)) := + let rn := align rn 2 in + match list_nth_z regs rn with + | Some r => + One (R r) :: rec (rn + 2) ofs + | None => + let ofs := align ofs 2 in + One (S Outgoing ofs ty) :: rec rn (ofs + 2) + end. + +Fixpoint loc_arguments_rec (va: bool) + (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := + match tyl with + | nil => nil + | ty :: tys => one_arg param_regs r ofs ty (loc_arguments_rec va tys) +(* + | (Tint | Tany32) as ty :: tys => + one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + | Tsingle as ty :: tys => + one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + | Tlong as ty :: tys => + if Archi.ptr64 + then one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) + else two_args int_param_regs r ofs (loc_arguments_rec va tys) + | (Tfloat | Tany64) as ty :: tys => + if va && negb Archi.ptr64 + then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys) + else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) +*) + end. + +(** [loc_arguments s] returns the list of locations where to store arguments + when calling a function with signature [s]. *) + +Definition loc_arguments (s: signature) : list (rpair loc) := + loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Definition max_outgoing_1 (accu: Z) (l: loc) : Z := + match l with + | S Outgoing ofs ty => Z.max accu (ofs + typesize ty) + | _ => accu + end. + +Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z := + match rl with + | One l => max_outgoing_1 accu l + | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2 + end. + +Definition size_arguments (s: signature) : Z := + List.fold_left max_outgoing_2 (loc_arguments s) 0. + +(** Argument locations are either non-temporary registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => is_callee_save r = false + | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) + | _ => False + end. + +Lemma loc_arguments_rec_charact: + forall va tyl rn ofs p, + ofs >= 0 -> + In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p. +Proof. + set (OK := fun (l: list (rpair loc)) => + forall p, In p l -> forall_rpair loc_argument_acceptable p). + set (OKF := fun (f: Z -> Z -> list (rpair loc)) => + forall rn ofs, ofs >= 0 -> OK (f rn ofs)). + set (OKREGS := fun (l: list mreg) => forall r, In r l -> is_callee_save r = false). + assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0). + { intros. + assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos). + omega. } + assert (SK: (if Archi.ptr64 then 2 else 1) > 0). + { destruct Archi.ptr64; omega. } + assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0). + { intros. destruct Archi.ptr64. omega. apply typesize_pos. } + assert (A: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (one_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO; red; unfold one_arg; intros. + destruct (list_nth_z regs rn) as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. auto using align_divides, typealign_pos. + - eapply OF; [idtac|eauto]. + generalize (AL ofs ty OO) (SKK ty); omega. + } + assert (B: forall regs rn ofs f, + OKREGS regs -> OKF f -> ofs >= 0 -> OK (two_args regs rn ofs f)). + { intros until f; intros OR OF OO; unfold two_args. + set (rn' := align rn 2). + set (ofs' := align ofs 2). + assert (OO': ofs' >= 0) by (apply (AL ofs Tlong); auto). + assert (DFL: OK (Twolong (S Outgoing (ofs' + 1) Tint) (S Outgoing ofs' Tint) + :: f rn' (ofs' + 2))). + { red; simpl; intros. destruct H. + - subst p; simpl. + repeat split; auto using Z.divide_1_l. omega. + - eapply OF; [idtac|eauto]. omega. + } + destruct (list_nth_z regs rn') as [r1|] eqn:NTH1; + destruct (list_nth_z regs (rn' + 1)) as [r2|] eqn:NTH2; + try apply DFL. + red; simpl; intros; destruct H. + - subst p; simpl. split; apply OR; eauto using list_nth_z_in. + - eapply OF; [idtac|eauto]. auto. + } + assert (C: forall regs rn ofs ty f, + OKREGS regs -> OKF f -> ofs >= 0 -> typealign ty = 1 -> OK (hybrid_arg regs rn ofs ty f)). + { intros until f; intros OR OF OO OTY; unfold hybrid_arg; red; intros. + set (rn' := align rn 2) in *. + destruct (list_nth_z regs rn') as [r|] eqn:NTH; destruct H. + - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. + - eapply OF; eauto. + - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l. + - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega. + } + assert (D: OKREGS param_regs). + { red. decide_goal. } + assert (E: OKREGS param_regs). + { red. decide_goal. } + + cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). + unfold OK. eauto. + induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. + - red; simpl; tauto. + - destruct ty1. ++ (* int *) apply A; auto. ++ (* float *) + apply A; auto. ++ (* long *) + apply A; auto. ++ (* single *) + apply A; auto. ++ (* any32 *) + apply A; auto. ++ (* any64 *) + apply A; auto. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (p: rpair loc), + In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. +Proof. + unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega. +Qed. + +(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) + +Remark fold_max_outgoing_above: + forall l n, fold_left max_outgoing_2 l n >= n. +Proof. + assert (A: forall n l, max_outgoing_1 n l >= n). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + induction l; simpl; intros. + - omega. + - eapply Zge_trans. eauto. + destruct a; simpl. apply A. eapply Zge_trans; eauto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +Proof. + intros. apply fold_max_outgoing_above. +Qed. + +Lemma loc_arguments_bounded: + forall (s: signature) (ofs: Z) (ty: typ), + In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> + ofs + typesize ty <= size_arguments s. +Proof. + intros until ty. + assert (A: forall n l, n <= max_outgoing_1 n l). + { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } + assert (B: forall p n, + In (S Outgoing ofs ty) (regs_of_rpair p) -> + ofs + typesize ty <= max_outgoing_2 n p). + { intros. destruct p; simpl in H; intuition; subst; simpl. + - xomega. + - eapply Z.le_trans. 2: apply A. xomega. + - xomega. } + assert (C: forall l n, + In (S Outgoing ofs ty) (regs_of_rpairs l) -> + ofs + typesize ty <= fold_left max_outgoing_2 l n). + { induction l; simpl; intros. + - contradiction. + - rewrite in_app_iff in H. destruct H. + + eapply Z.le_trans. eapply B; eauto. apply Z.ge_le. apply fold_max_outgoing_above. + + apply IHl; auto. + } + apply C. +Qed. + +Lemma loc_arguments_main: + loc_arguments signature_main = nil. +Proof. + reflexivity. +Qed. + + +Definition return_value_needs_normalization (t: rettype) : bool := false. diff --git a/kvx/DecBoolOps.v b/kvx/DecBoolOps.v new file mode 100644 index 00000000..1e0a6187 --- /dev/null +++ b/kvx/DecBoolOps.v @@ -0,0 +1,30 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Set Implicit Arguments. + +Theorem and_dec : forall A B C D : Prop, + { A } + { B } -> { C } + { D } -> + { A /\ C } + { (B /\ C) \/ (B /\ D) \/ (A /\ D) }. +Proof. + intros A B C D AB CD. + destruct AB; destruct CD. + - left. tauto. + - right. tauto. + - right. tauto. + - right. tauto. +Qed. + + diff --git a/kvx/DuplicateOpcodeHeuristic.ml b/kvx/DuplicateOpcodeHeuristic.ml new file mode 100644 index 00000000..38702e1b --- /dev/null +++ b/kvx/DuplicateOpcodeHeuristic.ml @@ -0,0 +1,41 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(* open Camlcoq *) +open Op +open Integers + +let opcode_heuristic code cond ifso ifnot is_loop_header = + match cond with + | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with + | Clt | Cle -> Some false + | Cgt | Cge -> Some true + | _ -> None + ) else None + | Ccompf c | Ccompfs c -> (match c with + | Ceq -> Some false + | Cne -> Some true + | _ -> None + ) + | Cnotcompf c | Cnotcompfs c -> (match c with + | Ceq -> Some true + | Cne -> Some false + | _ -> None + ) + | _ -> None diff --git a/kvx/ExtFloats.v b/kvx/ExtFloats.v new file mode 100644 index 00000000..b08503a5 --- /dev/null +++ b/kvx/ExtFloats.v @@ -0,0 +1,54 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Floats Integers ZArith. + +Module ExtFloat. +(** TODO check with the actual KVX; + this is what happens on x86 and may be inappropriate. *) + +Definition min (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float) (y : float) : float := + match Float.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. +End ExtFloat. + +Module ExtFloat32. +(** TODO check with the actual KVX *) + +Definition min (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Lt => x + | Some Gt | None => y + end. + +Definition max (x : float32) (y : float32) : float32 := + match Float32.compare x y with + | Some Eq | Some Gt => x + | Some Lt | None => y + end. + +Definition one := Float32.of_int (Int.repr (1%Z)). +Definition inv (x : float32) : float32 := + Float32.div one x. + +End ExtFloat32. diff --git a/kvx/ExtValues.v b/kvx/ExtValues.v new file mode 100644 index 00000000..3664c00a --- /dev/null +++ b/kvx/ExtValues.v @@ -0,0 +1,755 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import Integers. +Require Import Values. +Require Import Floats ExtFloats. + +Open Scope Z_scope. + +Definition abs_diff (x y : Z) := Z.abs (x - y). +Definition abs_diff2 (x y : Z) := + if x <=? y then y - x else x - y. +Lemma abs_diff2_correct : + forall x y : Z, (abs_diff x y) = (abs_diff2 x y). +Proof. + intros. + unfold abs_diff, abs_diff2. + unfold Z.leb. + pose proof (Z.compare_spec x y) as Hspec. + inv Hspec. + - rewrite Z.abs_eq; omega. + - rewrite Z.abs_neq; omega. + - rewrite Z.abs_eq; omega. +Qed. + +Inductive shift1_4 : Type := +| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. + +Definition z_of_shift1_4 (x : shift1_4) := + match x with + | SHIFT1 => 1 + | SHIFT2 => 2 + | SHIFT3 => 3 + | SHIFT4 => 4 + end. + +Definition shift1_4_of_z (x : Z) := + if Z.eq_dec x 1 then Some SHIFT1 + else if Z.eq_dec x 2 then Some SHIFT2 + else if Z.eq_dec x 3 then Some SHIFT3 + else if Z.eq_dec x 4 then Some SHIFT4 + else None. + +Lemma shift1_4_of_z_correct : + forall z, + match shift1_4_of_z z with + | Some x => z_of_shift1_4 x = z + | None => True + end. +Proof. + intro. unfold shift1_4_of_z. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + destruct (Z.eq_dec _ _); simpl; try congruence. + trivial. +Qed. + +Definition int_of_shift1_4 (x : shift1_4) := + Int.repr (z_of_shift1_4 x). + +Definition is_bitfield stop start := + (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int.zwordsize). + +Definition extfz stop start v := + if is_bitfield stop start + then + let stop' := Z.add stop Z.one in + match v with + | Vint w => + Vint (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + + +Definition extfs stop start v := + if is_bitfield stop start + then + let stop' := Z.add stop Z.one in + match v with + | Vint w => + Vint (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + +Definition zbitfield_mask stop start := + (Z.shiftl 1 (Z.succ stop)) - (Z.shiftl 1 start). + +Definition bitfield_mask stop start := + Vint(Int.repr (zbitfield_mask stop start)). + +Definition bitfield_maskl stop start := + Vlong(Int64.repr (zbitfield_mask stop start)). + +Definition insf stop start prev fld := + let mask := bitfield_mask stop start in + if is_bitfield stop start + then + Val.or (Val.and prev (Val.notint mask)) + (Val.and (Val.shl fld (Vint (Int.repr start))) mask) + else Vundef. + +Definition is_bitfieldl stop start := + (Z.leb start stop) + && (Z.geb start Z.zero) + && (Z.ltb stop Int64.zwordsize). + +Definition extfzl stop start v := + if is_bitfieldl stop start + then + let stop' := Z.add stop Z.one in + match v with + | Vlong w => + Vlong (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + + +Definition extfsl stop start v := + if is_bitfieldl stop start + then + let stop' := Z.add stop Z.one in + match v with + | Vlong w => + Vlong (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vundef + end + else Vundef. + +Definition insfl stop start prev fld := + let mask := bitfield_maskl stop start in + if is_bitfieldl stop start + then + Val.orl (Val.andl prev (Val.notl mask)) + (Val.andl (Val.shll fld (Vint (Int.repr start))) mask) + else Vundef. + +Fixpoint highest_bit (x : Z) (n : nat) : Z := + match n with + | O => 0 + | S n1 => + let n' := Z.of_N (N_of_nat n) in + if Z.testbit x n' + then n' + else highest_bit x n1 + end. + +Definition int_highest_bit (x : int) : Z := + highest_bit (Int.unsigned x) (31%nat). + + +Definition int64_highest_bit (x : int64) : Z := + highest_bit (Int64.unsigned x) (63%nat). + +Definition val_shrx (v1 v2: val): val := + match v1, v2 with + | Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 31) + then Vint(Int.shrx n1 n2) + else Vundef + | _, _ => Vundef + end. + +Definition val_shrxl (v1 v2: val): val := + match v1, v2 with + | Vlong n1, Vint n2 => + if Int.ltu n2 (Int.repr 63) + then Vlong(Int64.shrx' n1 n2) + else Vundef + | _, _ => Vundef + end. + +Remark modulus_fits_64: Int.modulus < Int64.max_unsigned. +Proof. + compute. + trivial. +Qed. + +Remark unsigned64_repr : + forall i, + -1 < i < Int.modulus -> + Int64.unsigned (Int64.repr i) = i. +Proof. + intros i H. + destruct H as [Hlow Hhigh]. + apply Int64.unsigned_repr. + split. { omega. } + pose proof modulus_fits_64. + omega. +Qed. + +Theorem divu_is_divlu: forall v1 v2 : val, + Val.divu v1 v2 = + match Val.divlu (Val.longofintu v1) (Val.longofintu v2) with + | None => None + | Some q => Some (Val.loword q) + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + rewrite Int.unsigned_repr by (compute; split; discriminate). + rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). + rewrite (unsigned64_repr i0_val) by assumption. + destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. + f_equal. f_equal. + unfold Int.divu, Int64.divu. simpl. + rewrite (unsigned64_repr i_val) by assumption. + rewrite (unsigned64_repr i0_val) by assumption. + unfold Int64.loword. + rewrite Int64.unsigned_repr. + reflexivity. + destruct (Z.eq_dec i0_val 1). + {subst i0_val. + pose proof modulus_fits_64. + rewrite Zdiv_1_r. + omega. + } + destruct (Z.eq_dec i_val 0). + { subst i_val. compute. + split; + intro ABSURD; + discriminate ABSURD. } + assert ((i_val / i0_val) < i_val). + { apply Z_div_lt; omega. } + split. + { apply Z_div_pos; omega. } + pose proof modulus_fits_64. + omega. +Qed. + +Theorem modu_is_modlu: forall v1 v2 : val, + Val.modu v1 v2 = + match Val.modlu (Val.longofintu v1) (Val.longofintu v2) with + | None => None + | Some q => Some (Val.loword q) + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + rewrite Int.unsigned_repr by (compute; split; discriminate). + rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). + rewrite (unsigned64_repr i0_val) by assumption. + destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. + f_equal. f_equal. + unfold Int.modu, Int64.modu. simpl. + rewrite (unsigned64_repr i_val) by assumption. + rewrite (unsigned64_repr i0_val) by assumption. + unfold Int64.loword. + rewrite Int64.unsigned_repr. + reflexivity. + assert((i_val mod i0_val) < i0_val). + apply Z_mod_lt. + omega. + split. + { apply Z_mod_lt. + omega. } + pose proof modulus_fits_64. + omega. +Qed. + +Remark if_zlt_0_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt 0 Int.half_modulus) then x else y) = x. +Proof. + reflexivity. +Qed. + +Remark if_zlt_mone_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt (Int.unsigned Int.mone) Int.half_modulus) then x else y) = y. +Proof. + reflexivity. +Qed. + +Remark if_zlt_min_signed_half_modulus : + forall T : Type, + forall x y: T, + (if (zlt (Int.unsigned (Int.repr Int.min_signed)) + Int.half_modulus) + then x + else y) = y. +Proof. + reflexivity. +Qed. + +Lemma repr_unsigned64_repr: + forall x, Int.repr (Int64.unsigned (Int64.repr x)) = Int.repr x. +Proof. + intros. + apply Int.eqm_samerepr. + unfold Int.eqm. + unfold Zbits.eqmod. + pose proof (Int64.eqm_unsigned_repr x) as H64. + unfold Int64.eqm in H64. + unfold Zbits.eqmod in H64. + destruct H64 as [k64 H64]. + change Int64.modulus with 18446744073709551616 in *. + change Int.modulus with 4294967296. + exists (-4294967296 * k64). + set (y := Int64.unsigned (Int64.repr x)) in *. + rewrite H64. + clear H64. + omega. +Qed. + +(* +Theorem divs_is_divls: forall v1 v2 : val, + match Val.divs v1 v2 with + | Some q => + match Val.divls (Val.longofint v1) (Val.longofint v2) with + | None => False + | Some q' => q = Val.loword q' + end + | None => True + end. +Proof. + intros. + destruct v1; simpl; trivial. + destruct v2; simpl; trivial. + destruct i as [i_val i_range]. + destruct i0 as [i0_val i0_range]. + simpl. + unfold Int.eq, Int64.eq, Int.zero, Int64.zero. + simpl. + replace (Int.unsigned (Int.repr 0)) with 0 in * by reflexivity. + destruct (zeq _ _) as [H0' | Hnot0]; simpl; trivial. + destruct (zeq i_val (Int.unsigned (Int.repr Int.min_signed))) as [Hmin | Hnotmin]; simpl. + { subst. + destruct (zeq i0_val (Int.unsigned Int.mone)) as [Hmone | Hnotmone]; trivial. + unfold Int.signed. simpl. + replace (Int64.unsigned (Int64.repr 0)) with 0 in * by reflexivity. + rewrite if_zlt_min_signed_half_modulus. + replace (if + zeq + (Int64.unsigned + (Int64.repr + (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) + (Int64.unsigned (Int64.repr Int64.min_signed)) + then true + else false) with false by reflexivity. + simpl. + rewrite orb_false_r. + destruct (zlt i0_val Int.half_modulus) as [Hlt_half | Hge_half]. + { + replace Int.half_modulus with 2147483648 in * by reflexivity. + rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; omega). + destruct (zeq _ _) as [ | Hneq0]; try omega. clear Hneq0. + unfold Val.loword. + f_equal. + unfold Int64.divs, Int.divs, Int64.loword. + unfold Int.signed, Int64.signed. simpl. + rewrite if_zlt_min_signed_half_modulus. + change Int.half_modulus with 2147483648 in *. + destruct (zlt _ _) as [discard|]; try omega. clear discard. + change (Int64.unsigned + (Int64.repr + (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) + with 18446744071562067968. + change Int64.half_modulus with 9223372036854775808. + change Int64.modulus with 18446744073709551616. + simpl. + rewrite (Int64.unsigned_repr i0_val) by (change Int64.max_unsigned with 18446744073709551615; omega). + destruct (zlt i0_val 9223372036854775808) as [discard |]; try omega. + clear discard. + change (Int.unsigned (Int.repr Int.min_signed) - Int.modulus) with (-2147483648). + destruct (Z.eq_dec i0_val 1) as [H1 | Hnot1]. + { subst. + rewrite Z.quot_1_r. + apply Int.eqm_samerepr. + unfold Int.eqm. + change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968. + unfold Zbits.eqmod. + change Int.modulus with 4294967296. + exists (-4294967296). + compute. + reflexivity. + } + change (-2147483648) with (-(2147483648)). + rewrite Z.quot_opp_l by assumption. + rewrite repr_unsigned64_repr. + reflexivity. + } + destruct (zeq _ _) as [Hmod|Hnmod]. + { + rewrite Int64.unsigned_repr_eq in Hmod. + set (delta := (i0_val - Int.modulus)) in *. + assert (delta = Int64.modulus*(delta/Int64.modulus)) as Hdelta. + { apply Z_div_exact_full_2. + compute. omega. + assumption. } + set (k := (delta / Int64.modulus)) in *. + change Int64.modulus with 18446744073709551616 in *. + change Int.modulus with 4294967296 in *. + change Int.half_modulus with 2147483648 in *. + change (Int.unsigned Int.mone) with 4294967295 in *. + omega. + } + unfold Int.divs, Int64.divs, Val.loword, Int64.loword. + change (Int.unsigned (Int.repr Int.min_signed)) with 2147483648. + change Int.modulus with 4294967296. + change (Int64.signed (Int64.repr (2147483648 - 4294967296))) with (-2147483648). + f_equal. + change (Int.signed {| Int.intval := 2147483648; Int.intrange := i_range |}) + with (-2147483648). + rewrite Int64.signed_repr. + { + replace (Int.signed {| Int.intval := i0_val; Int.intrange := i0_range |}) with (i0_val - 4294967296). + { rewrite repr_unsigned64_repr. + reflexivity. + } + *) + +Lemma big_unsigned_signed: + forall x, + (Int.unsigned x >= Int.half_modulus) -> + (Int.signed x) = (Int.unsigned x) - Int.modulus. +Proof. + destruct x as [xval xrange]. + intro BIG. + unfold Int.signed, Int.unsigned in *. simpl in *. + destruct (zlt _ _). + omega. + trivial. +Qed. + +(* +Lemma signed_0_eqb : + forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero. +Qed. + *) + +Lemma Z_quot_le: forall a b, + 0 <= a -> 1 <= b -> Z.quot a b <= a. +Proof. + intros a b Ha Hb. + destruct (Z.eq_dec b 1) as [Hb1 | Hb1]. + { (* b=1 *) + subst. + rewrite Z.quot_1_r. + auto with zarith. + } + destruct (Z.eq_dec a 0) as [Ha0 | Ha0]. + { (* a=0 *) + subst. + rewrite Z.quot_0_l. + auto with zarith. + omega. + } + assert ((Z.quot a b) < a). + { + apply Z.quot_lt; omega. + } + auto with zarith. +Qed. + +(* +Lemma divs_is_quot: forall v1 v2 : val, + Val.divs v1 v2 = + match v1, v2 with + | (Vint w1), (Vint w2) => + let q := Z.quot (Int.signed w1) (Int.signed w2) in + if (negb (Z.eqb (Int.signed w2) 0)) + && (Z.geb q Int.min_signed) && (Z.leb q Int.max_signed) + then Some (Vint (Int.repr q)) + else None + | _, _ => None + end. + +Proof. + destruct v1; destruct v2; simpl; trivial. + unfold Int.divs. + rewrite signed_0_eqb. + destruct (Int.eq i0 Int.zero) eqn:Eeq0; simpl; trivial. + destruct (Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:EXCEPTION. + { replace (Int.signed i0) with (-1). + replace (Int.signed i) with Int.min_signed. + change Int.min_signed with (-2147483648). + change Int.max_signed with (2147483647). + compute. + reflexivity. + { unfold Int.eq in EXCEPTION. + destruct (zeq _ _) as [Hmin | ] in EXCEPTION; try discriminate. + change Int.min_signed with (-2147483648). + change (Int.unsigned (Int.repr Int.min_signed)) with (2147483648) in *. + rewrite big_unsigned_signed. + change Int.modulus with 4294967296. + omega. + change Int.half_modulus with 2147483648. + omega. + } + unfold Int.eq in EXCEPTION. + destruct (zeq _ _) in EXCEPTION; try discriminate. + destruct (zeq _ _) as [Hmone | ] in EXCEPTION; try discriminate. + destruct i0 as [i0val i0range]; unfold Int.signed in *; simpl in *. + rewrite Hmone. + reflexivity. + } + replace (Int.signed i ÷ Int.signed i0 >=? Int.min_signed) with true. + replace (Int.signed i ÷ Int.signed i0 <=? Int.max_signed) with true. + reflexivity. + { assert (Int.signed i ÷ Int.signed i0 <= Int.max_signed). + { + destruct (Z_lt_le_dec (Int.signed i) 0). + { + apply Z.le_trans with (m:=0). + rewrite <- (Z.quot_0_l (Int.signed i0)). + Require Import Coq.ZArith.Zquot. + apply Z_quot_monotone. + } + assert ( Int.signed i ÷ Int.signed i0 <= Int.signed i). + apply Z_quot_le. + } + } + + *) + +Require Import Coq.ZArith.Zquot. +Lemma Z_quot_pos_pos_bound: forall a b m, + 0 <= a <= m -> 1 <= b -> 0 <= Z.quot a b <= m. +Proof. + intros. + split. + { rewrite <- (Z.quot_0_l b) by omega. + apply Z_quot_monotone; omega. + } + apply Z.le_trans with (m := a). + { + apply Z_quot_le; tauto. + } + tauto. +Qed. +Lemma Z_quot_neg_pos_bound: forall a b m, + m <= a <= 0 -> 1 <= b -> m <= Z.quot a b <= 0. + intros. + assert (0 <= - (a ÷ b) <= -m). + { + rewrite <- Z.quot_opp_l by omega. + apply Z_quot_pos_pos_bound; omega. + } + omega. +Qed. + +Lemma Z_quot_signed_pos_bound: forall a b, + Int.min_signed <= a <= Int.max_signed -> 1 <= b -> + Int.min_signed <= Z.quot a b <= Int.max_signed. +Proof. + intros. + destruct (Z_lt_ge_dec a 0). + { + split. + { apply Z_quot_neg_pos_bound; omega. } + { eapply Z.le_trans with (m := 0). + { apply Z_quot_neg_pos_bound with (m := Int.min_signed); trivial. + split. tauto. auto with zarith. + } + discriminate. + } + } + { split. + { eapply Z.le_trans with (m := 0). + discriminate. + apply Z_quot_pos_pos_bound with (m := Int.max_signed); trivial. + split. omega. tauto. + } + { apply Z_quot_pos_pos_bound; omega. + } + } +Qed. + +Lemma Z_quot_signed_neg_bound: forall a b, + Int.min_signed <= a <= Int.max_signed -> b < -1 -> + Int.min_signed <= Z.quot a b <= Int.max_signed. +Proof. + change Int.min_signed with (-2147483648). + change Int.max_signed with 2147483647. + intros. + + replace b with (-(-b)) by auto with zarith. + rewrite Z.quot_opp_r by omega. + assert (-2147483647 <= (a ÷ - b) <= 2147483648). + 2: omega. + + destruct (Z_lt_ge_dec a 0). + { + replace a with (-(-a)) by auto with zarith. + rewrite Z.quot_opp_l by omega. + assert (-2147483648 <= - a ÷ - b <= 2147483647). + 2: omega. + split. + { + rewrite Z.quot_opp_l by omega. + assert (a ÷ - b <= 2147483648). + 2: omega. + { + apply Z.le_trans with (m := 0). + rewrite <- (Z.quot_0_l (-b)) by omega. + apply Z_quot_monotone; omega. + discriminate. + } + } + assert (- a ÷ - b < -a ). + 2: omega. + apply Z_quot_lt; omega. + } + { + split. + { apply Z.le_trans with (m := 0). + discriminate. + rewrite <- (Z.quot_0_l (-b)) by omega. + apply Z_quot_monotone; omega. + } + { apply Z.le_trans with (m := a). + apply Z_quot_le. + all: omega. + } + } +Qed. + +Lemma sub_add_neg : + forall x y, Val.sub x y = Val.add x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.sub_add_opp. +Qed. + +Lemma neg_mul_distr_r : + forall x y, Val.neg (Val.mul x y) = Val.mul x (Val.neg y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int.neg_mul_distr_r. +Qed. + +(* pointer diff +Lemma sub_addl_negl : + forall x y, Val.subl x y = Val.addl x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + + f_equal. apply Int64.sub_add_opp. + + destruct (Archi.ptr64) eqn:ARCHI64; trivial. + f_equal. rewrite Ptrofs.sub_add_opp. + pose (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 i0) i0) as Hagree. + unfold Ptrofs.agree64 in Hagree. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite Hagree. + pose (Ptrofs.agree64_of_int ARCHI64 (Int64.neg i0)) as Hagree2. + rewrite Hagree2. + reflexivity. + exact (Ptrofs.agree64_of_int ARCHI64 i0). + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + destruct (eq_block _ _); simpl; trivial. +Qed. + *) + +Lemma negl_mull_distr_r : + forall x y, Val.negl (Val.mull x y) = Val.mull x (Val.negl y). +Proof. + destruct x; destruct y; simpl; trivial. + f_equal. + apply Int64.neg_mul_distr_r. +Qed. + +Definition addx sh v1 v2 := + Val.add v2 (Val.shl v1 (Vint sh)). + +Definition addxl sh v1 v2 := + Val.addl v2 (Val.shll v1 (Vint sh)). + +Definition revsubx sh v1 v2 := + Val.sub v2 (Val.shl v1 (Vint sh)). + +Definition revsubxl sh v1 v2 := + Val.subl v2 (Val.shll v1 (Vint sh)). + +Definition minf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.min f1 f2) + | _, _ => Vundef + end. + +Definition maxf v1 v2 := + match v1, v2 with + | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.max f1 f2) + | _, _ => Vundef + end. + +Definition minfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.min f1 f2) + | _, _ => Vundef + end. + +Definition maxfs v1 v2 := + match v1, v2 with + | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2) + | _, _ => Vundef + end. + +Definition invfs v1 := + match v1 with + | (Vsingle f1) => Vsingle (ExtFloat32.inv f1) + | _ => Vundef + end. + +Definition triple_op_float f v1 v2 v3 := + match v1, v2, v3 with + | (Vfloat f1), (Vfloat f2), (Vfloat f3) => Vfloat (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition triple_op_single f v1 v2 v3 := + match v1, v2, v3 with + | (Vsingle f1), (Vsingle f2), (Vsingle f3) => Vsingle (f f1 f2 f3) + | _, _, _ => Vundef + end. + +Definition fmaddf := triple_op_float (fun f1 f2 f3 => Float.fma f2 f3 f1). +Definition fmaddfs := triple_op_single (fun f1 f2 f3 => Float32.fma f2 f3 f1). + +Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma (Float.neg f2) f3 f1). +Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma (Float32.neg f2) f3 f1). diff --git a/kvx/InstructionScheduler.ml b/kvx/InstructionScheduler.ml new file mode 100644 index 00000000..e4dc3f97 --- /dev/null +++ b/kvx/InstructionScheduler.ml @@ -0,0 +1,1247 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Schedule instructions on a synchronized pipeline +@author David Monniaux, CNRS, VERIMAG *) + +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int };; + +type problem = { + max_latency : int; + resource_bounds : int array; + instruction_usages : int array array; + latency_constraints : latency_constraint list; + };; + +let print_problem channel problem = + (if problem.max_latency >= 0 + then Printf.fprintf channel "max makespan: %d\n" problem.max_latency); + output_string channel "resource bounds:"; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) problem.resource_bounds); + output_string channel ";\n"; + (Array.iteri (fun i v -> + Printf.fprintf channel "instr%d:" i; + (Array.iter (fun b -> Printf.fprintf channel " %d" b) v); + output_string channel ";\n") problem.instruction_usages); + List.iter (fun instr -> + Printf.printf "t%d - t%d >= %d;\n" + instr.instr_to instr.instr_from instr.latency) + problem.latency_constraints;; + +let get_nr_instructions problem = Array.length problem.instruction_usages;; +let get_nr_resources problem = Array.length problem.resource_bounds;; + +type solution = int array +type scheduler = problem -> solution option + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option = + "caml_gecode_schedule_instr";; + *) + +let maximum_slot_used times = + let maxi = ref (-1) in + for i=0 to (Array.length times)-2 + do + maxi := max !maxi times.(i) + done; + !maxi;; + +let check_schedule (problem : problem) (times : solution) = + let nr_instructions = get_nr_instructions problem in + (if Array.length times <> nr_instructions+1 + then failwith + (Printf.sprintf "check_schedule: %d times expected, got %d" + (nr_instructions+1) (Array.length times))); + (if problem.max_latency >= 0 && times.(nr_instructions)> problem.max_latency + then failwith "check_schedule: max_latency exceeded"); + (Array.iteri (fun i time -> + (if time < 0 + then failwith (Printf.sprintf "time[%d] < 0" i))) times); + let slot_resources = Array.init ((maximum_slot_used times)+1) + (fun _ -> Array.copy problem.resource_bounds) in + for i=0 to nr_instructions -1 + do + let remaining_resources = slot_resources.(times.(i)) + and used_resources = problem.instruction_usages.(i) in + for resource=0 to (Array.length used_resources)-1 + do + let after = remaining_resources.(resource) - used_resources.(resource) in + (if after < 0 + then failwith (Printf.sprintf "check_schedule: instruction %d exceeds resource %d at slot %d" i resource times.(i))); + remaining_resources.(resource) <- after + done + done; + List.iter (fun ctr -> + if times.(ctr.instr_to) - times.(ctr.instr_from) < ctr.latency + then failwith (Printf.sprintf "check_schedule: time[%d]=%d - time[%d]=%d < %d" + ctr.instr_to times.(ctr.instr_to) + ctr.instr_from times.(ctr.instr_from) + ctr.latency) + ) problem.latency_constraints;; + +let bound_max_time problem = + let total = ref(Array.length problem.instruction_usages) in + List.iter (fun ctr -> total := !total + ctr.latency) problem.latency_constraints; + !total;; + +let vector_less_equal a b = + try + Array.iter2 (fun x y -> + if x>y + then raise Exit) a b; + true + with Exit -> false;; + +let vector_subtract a b = + assert ((Array.length a) = (Array.length b)); + for i=0 to (Array.length a)-1 + do + b.(i) <- b.(i) - a.(i) + done;; + +(* The version with critical path ordering is much better! *) +type list_scheduler_order = + | INSTRUCTION_ORDER + | CRITICAL_PATH_ORDER;; + +let int_max (x : int) (y : int) = + if x > y then x else y;; + +let int_min (x : int) (y : int) = + if x < y then x else y;; + +let get_predecessors problem = + let nr_instructions = get_nr_instructions problem in + let predecessors = Array.make (nr_instructions+1) [] in + List.iter (fun ctr -> + predecessors.(ctr.instr_to) <- + (ctr.instr_from, ctr.latency)::predecessors.(ctr.instr_to)) + problem.latency_constraints; + predecessors;; + +let get_successors problem = + let nr_instructions = get_nr_instructions problem in + let successors = Array.make nr_instructions [] in + List.iter (fun ctr -> + successors.(ctr.instr_from) <- + (ctr.instr_to, ctr.latency)::successors.(ctr.instr_from)) + problem.latency_constraints; + successors;; + +let critical_paths successors = + let nr_instructions = Array.length successors in + let path_lengths = Array.make nr_instructions (-1) in + let rec compute i = + if i=nr_instructions then 0 else + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 1 successors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = nr_instructions-1 downto 0 + do + ignore (compute i) + done; + path_lengths;; + +let maximum_critical_path problem = + let paths = critical_paths (get_successors problem) in + Array.fold_left int_max 0 paths;; + +let get_earliest_dates predecessors = + let nr_instructions = (Array.length predecessors)-1 in + let path_lengths = Array.make (nr_instructions+1) (-1) in + let rec compute i = + match path_lengths.(i) with + | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" + | -1 -> path_lengths.(i) <- -2; + let x = List.fold_left + (fun cur (j, latency)-> int_max cur (latency+(compute j))) + 0 predecessors.(i) + in path_lengths.(i) <- x; x + | x -> x + in for i = 0 to nr_instructions + do + ignore (compute i) + done; + for i = 0 to nr_instructions - 1 + do + path_lengths.(nr_instructions) <- int_max + path_lengths.(nr_instructions) (1 + path_lengths.(i)) + done; + path_lengths;; + +exception Unschedulable + +let get_latest_dates deadline successors = + let nr_instructions = Array.length successors + and path_lengths = critical_paths successors in + Array.init (nr_instructions + 1) + (fun i -> + if i < nr_instructions then + let path_length = path_lengths.(i) in + assert (path_length >= 1); + (if path_length > deadline + then raise Unschedulable); + deadline - path_length + else deadline);; + +let priority_list_scheduler (order : list_scheduler_order) + (problem : problem) : + solution option = + let nr_instructions = get_nr_instructions problem in + let successors = get_successors problem + and predecessors = get_predecessors problem + and times = Array.make (nr_instructions+1) (-1) in + + let priorities = match order with + | INSTRUCTION_ORDER -> None + | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in + + let module InstrSet = + Set.Make (struct type t=int + let compare = match priorities with + | None -> (fun x y -> x - y) + | Some p -> (fun x y -> + (match p.(y)-p.(x) with + | 0 -> x - y + | z -> z)) + end) in + + let max_time = bound_max_time problem in + let ready = Array.make max_time InstrSet.empty in + Array.iteri (fun i preds -> + if i + if times.(j) < 0 + then raise Exit + else let t = times.(j) + latency in + if t > !time + then time := t) predecessors.(i); + assert(!time >= 0); + !time + with Exit -> -1 + + in + let advance_time() = + begin + (if !current_time < max_time-1 + then + begin + Array.blit problem.resource_bounds 0 current_resources 0 + (Array.length current_resources); + ready.(!current_time + 1) <- + InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1)); + ready.(!current_time) <- InstrSet.empty; + end); + incr current_time + end in + + let attempt_scheduling ready usages = + let result = ref (-1) in + try + InstrSet.iter (fun i -> + (* Printf.printf "trying scheduling %d\n" i; + pr int_vector usages.(i); + print _vector current_resources; *) + if vector_less_equal usages.(i) current_resources + then + begin + vector_subtract usages.(i) current_resources; + result := i; + raise Exit + end) ready; + -1 + with Exit -> !result in + + while !current_time < max_time + do + if (InstrSet.is_empty ready.(!current_time)) + then advance_time() + else + match attempt_scheduling ready.(!current_time) + problem.instruction_usages with + | -1 -> advance_time() + | i -> + begin + assert(times.(i) < 0); + times.(i) <- !current_time; + ready.(!current_time) <- InstrSet.remove i (ready.(!current_time)); + List.iter (fun (instr_to, latency) -> + if instr_to < nr_instructions then + match earliest_time instr_to with + | -1 -> () + | to_time -> + ready.(to_time) <- InstrSet.add instr_to ready.(to_time)) + successors.(i); + successors.(i) <- [] + end + done; + try + let final_time = ref (-1) in + for i=0 to nr_instructions-1 + do + (if times.(i) < 0 then raise Exit); + (if !final_time < times.(i)+1 then final_time := times.(i)+1) + done; + List.iter (fun (i, latency) -> + let target_time = latency + times.(i) in + if target_time > !final_time + then final_time := target_time + ) predecessors.(nr_instructions); + times.(nr_instructions) <- !final_time; + Some times + with Exit -> None;; + +let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; + +(* dummy code for placating ocaml's warnings *) +let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; + +type bundle = int list;; + +let rec extract_deps_to index = function + | [] -> [] + | dep :: deps -> let extracts = extract_deps_to index deps in + if (dep.instr_to == index) then + dep :: extracts + else + extracts + +exception InvalidBundle;; + +let dependency_check problem bundle index = + let index_deps = extract_deps_to index problem.latency_constraints in + List.iter (fun i -> + List.iter (fun dep -> + if (dep.instr_from == i) then raise InvalidBundle + ) index_deps + ) bundle;; + +let rec make_bundle problem resources bundle index = + let resources_copy = Array.copy resources in + let nr_instructions = get_nr_instructions problem in + if (index >= nr_instructions) then (bundle, index+1) else + let inst_usage = problem.instruction_usages.(index) in + try match vector_less_equal inst_usage resources with + | false -> raise InvalidBundle + | true -> ( + dependency_check problem bundle index; + vector_subtract problem.instruction_usages.(index) resources_copy; + make_bundle problem resources_copy (index::bundle) (index+1) + ) + with InvalidBundle -> (bundle, index);; + +let rec make_bundles problem index : bundle list = + if index >= get_nr_instructions problem then + [] + else + let (bundle, new_index) = make_bundle problem problem.resource_bounds [] index in + bundle :: (make_bundles problem new_index);; + +let bundles_to_schedule problem bundles : solution = + let nr_instructions = get_nr_instructions problem in + let schedule = Array.make (nr_instructions+1) (nr_instructions+4) in + let time = ref 0 in + List.iter (fun bundle -> + begin + List.iter (fun i -> + schedule.(i) <- !time + ) bundle; + time := !time + 1 + end + ) bundles; schedule;; + +let greedy_scheduler (problem : problem) : solution option = + let bundles = make_bundles problem 0 in + Some (bundles_to_schedule problem bundles);; + +(* alternate implementation +let swap_array_elements a i j = + let x = a.(i) in + a.(i) <- a.(j); + a.(j) <- x;; + +let array_reverse_slice a first last = + let i = ref first and j = ref last in + while i < j + do + swap_array_elements a !i !j; + incr i; + decr j + done;; + +let array_reverse a = + let a' = Array.copy a in + array_reverse_slice a' 0 ((Array.length a)-1); + a';; + *) + +(* unneeded +let array_reverse a = + let n=Array.length a in + Array.init n (fun i -> a.(n-1-i));; + *) + +let reverse_constraint nr_instructions ctr = + { instr_to = nr_instructions -ctr.instr_from; + instr_from = nr_instructions - ctr.instr_to; + latency = ctr.latency };; + +(* unneeded +let rec list_map_filter f = function + | [] -> [] + | h::t -> + (match f h with + | None -> list_map_filter f t + | Some x -> x :: (list_map_filter f t));; + *) + +let reverse_problem problem = + let nr_instructions = get_nr_instructions problem in + { + max_latency = problem.max_latency; + resource_bounds = problem.resource_bounds; + instruction_usages = Array.init (nr_instructions + 1) + (fun i -> + if i=0 + then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); + latency_constraints = List.map (reverse_constraint nr_instructions) + problem.latency_constraints + };; + +let max_scheduled_time solution = + let time = ref (-1) in + for i = 0 to ((Array.length solution) - 2) + do + time := max !time solution.(i) + done; + !time;; + +(* +let recompute_makespan problem solution = + let n = (Array.length solution) - 1 and ms = ref 0 in + List.iter (fun cstr -> + if cstr.instr_to = n + then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) + ) problem.latency_constraints; + !ms;; + *) + +let schedule_reversed (scheduler : problem -> solution option) + (problem : problem) = + match scheduler (reverse_problem problem) with + | None -> None + | Some solution -> + let nr_instructions = get_nr_instructions problem in + let makespan = max_scheduled_time solution in + let ret = Array.init (nr_instructions + 1) + (fun i -> makespan-solution.(nr_instructions-i)) in + ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) + (ret.(nr_instructions)); + Some ret;; + +(** Schedule the problem using a greedy list scheduling algorithm, from the end. *) +let reverse_list_scheduler = schedule_reversed list_scheduler;; + +let check_problem problem = + (if (Array.length problem.instruction_usages) < 1 + then failwith "length(problem.instruction_usages) < 1");; + +let validated_scheduler (scheduler : problem -> solution option) + (problem : problem) = + check_problem problem; + match scheduler problem with + | None -> None + | (Some solution) as ret -> check_schedule problem solution; ret;; + +let get_max_latency solution = + solution.((Array.length solution)-1);; + +let show_date_ranges problem = + let deadline = problem.max_latency in + assert(deadline >= 0); + let successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates : int array = get_earliest_dates predecessors + and latest_dates : int array = get_latest_dates deadline successors in + assert ((Array.length earliest_dates) = + (Array.length latest_dates)); + Array.iteri (fun i early -> + let late = latest_dates.(i) in + Printf.printf "t[%d] in %d..%d\n" i early late) + earliest_dates;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper = { + mapper_pb_type : pseudo_boolean_problem_type; + mapper_nr_instructions : int; + mapper_nr_pb_variables : int; + mapper_earliest_dates : int array; + mapper_latest_dates : int array; + mapper_var_offsets : int array; + mapper_final_predecessors : (int * int) list +};; + +(* Latency constraints are: + presence of instr-to at each t <= sum of presences of instr-from at compatible times + + if reverse_encoding + presence of instr-from at each t <= sum of presences of instr-to at compatible times *) + +(* Experiments show reverse_encoding=true multiplies time by 2 in sat4j + without making hard instances easier *) +let direct_encoding = false +and reverse_encoding = false +and delta_encoding = true + +let pseudo_boolean_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + let var_offsets = Array.make + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) 0 in + let nr_pb_variables = + (let nr = ref 0 in + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + var_offsets.(i) <- !nr; + nr := !nr + latest_dates.(i) - earliest_dates.(i) + 1 + done; + !nr) + and nr_pb_constraints = + (match pb_type with + | OPTIMIZATION -> nr_instructions+1 + | SATISFIABILITY -> nr_instructions) + + + (let count = ref 0 in + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + try + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 then raise Exit + done + with Exit -> incr count + done + done; + !count) + + + (let count=ref 0 in + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions + then count := !count + 1 + latest_dates.(ctr.instr_to) + - earliest_dates.(ctr.instr_to) + + (if reverse_encoding + then 1 + latest_dates.(ctr.instr_from) + - earliest_dates.(ctr.instr_from) + else 0) + ) + problem.latency_constraints; + !count) + + + (match pb_type with + | OPTIMIZATION -> (1 + deadline - earliest_dates.(nr_instructions)) * nr_instructions + | SATISFIABILITY -> 0) + and measured_nr_constraints = ref 0 in + + let pb_var i t = + assert(t >= earliest_dates.(i)); + assert(t <= latest_dates.(i)); + let v = 1+var_offsets.(i)+t-earliest_dates.(i) in + assert(v <= nr_pb_variables); + Printf.sprintf "x%d" v in + + let end_constraint () = + begin + output_string channel ";\n"; + incr measured_nr_constraints + end in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + Printf.fprintf channel ">= 0"; + end_constraint() + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0"; + end_constraint() + in + + Printf.fprintf channel "* #variable= %d #constraint= %d\n" nr_pb_variables nr_pb_constraints; + Printf.fprintf channel "* nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + output_string channel "min:"; + for t=earliest_dates.(nr_instructions) to deadline + do + Printf.fprintf channel " %+d %s" t (pb_var nr_instructions t) + done; + output_string channel ";\n"; + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "* t[%d] in %d..%d\n" i early late; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1"; + end_constraint() + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "* resource #%d at t=%d <= %d\n" j t bound; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d" (-bound); + end_constraint(); + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done; + if reverse_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + assert (!measured_nr_constraints = nr_pb_constraints); + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = nr_pb_variables; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = var_offsets; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +type pb_answer = + | Positive + | Negative + | Unknown + +let line_to_pb_solution sol line nr_pb_variables = + let assign s v = + begin + let i = int_of_string s in + sol.(i-1) <- v + end in + List.iter + begin + function "" -> () + | item -> + (match String.get item 0 with + | '+' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Positive + | '-' -> + assert ((String.length item) >= 3); + assert ((String.get item 1) = 'x'); + assign (String.sub item 2 ((String.length item)-2)) Negative + | 'x' -> + assert ((String.length item) >= 2); + assign (String.sub item 1 ((String.length item)-1)) Positive + | _ -> failwith "syntax error in pseudo Boolean solution: epected + - or x" + ) + end + (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; + +let pb_solution_to_schedule mapper pb_solution = + Array.mapi (fun i offset -> + let first = mapper.mapper_earliest_dates.(i) + and last = mapper.mapper_latest_dates.(i) + and time = ref (-1) in + for t=first to last + do + match pb_solution.(t - first + offset) with + | Positive -> + (if !time = -1 + then time:=t + else failwith "duplicate time in pseudo boolean solution") + | Negative -> () + | Unknown -> failwith "unknown value in pseudo boolean solution" + done; + (if !time = -1 + then failwith "no time in pseudo boolean solution"); + !time + ) mapper.mapper_var_offsets;; + +let pseudo_boolean_read_solution mapper channel = + let optimum = ref (-1) + and optimum_found = ref false + and solution = Array.make mapper.mapper_nr_pb_variables Unknown in + try + while true do + match input_line channel with + | "" -> () + | line -> + begin + match String.get line 0 with + | 'c' -> () + | 'o' -> + assert ((String.length line) >= 2); + assert ((String.get line 1) = ' '); + optimum := int_of_string (String.sub line 2 ((String.length line)-2)) + | 's' -> (match line with + | "s OPTIMUM FOUND" -> optimum_found := true + | "s SATISFIABLE" -> () + | "s UNSATISFIABLE" -> close_in channel; + raise Unschedulable + | _ -> failwith line) + | 'v' -> line_to_pb_solution solution line mapper.mapper_nr_pb_variables + | x -> Printf.printf "unknown: %s\n" line + end + done; + assert false + with End_of_file -> + close_in channel; + begin + let sol = pb_solution_to_schedule mapper solution in + sol + end;; + +let recompute_max_latency mapper solution = + let maxi = ref (-1) in + for i=0 to (mapper.mapper_nr_instructions-1) + do + maxi := int_max !maxi (1+solution.(i)) + done; + List.iter (fun (i, latency) -> + maxi := int_max !maxi (solution.(i) + latency)) mapper.mapper_final_predecessors; + !maxi;; + +let adjust_check_solution mapper solution = + match mapper.mapper_pb_type with + | OPTIMIZATION -> + let max_latency = recompute_max_latency mapper solution in + assert (max_latency = solution.(mapper.mapper_nr_instructions)); + solution + | SATISFIABILITY -> + let max_latency = recompute_max_latency mapper solution in + Array.init (mapper.mapper_nr_instructions+1) + (fun i -> if i < mapper.mapper_nr_instructions + then solution.(i) + else max_latency);; + +(* let pseudo_boolean_solver = ref "/local/monniaux/progs/naps/naps" *) +(* let pseudo_boolean_solver = ref "/local/monniaux/packages/sat4j/org.sat4j.pb.jar CuttingPlanes" *) + +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar CuttingPlanes" *) +(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar" *) +(* let pseudo_boolean_solver = ref "clasp" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) +(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) +(* let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" *) +let pseudo_boolean_solver = ref "pb_solver" + +let pseudo_boolean_scheduler pb_type problem = + try + let filename_in = "problem.opb" + (* needed only if not using stdout and filename_out = "problem.sol" *) in + let opb_problem = open_out filename_in in + let mapper = pseudo_boolean_print_problem opb_problem problem pb_type in + close_out opb_problem; + + let opb_solution = Unix.open_process_in (!pseudo_boolean_solver ^ " " ^ filename_in) in + let ret = adjust_check_solution mapper (pseudo_boolean_read_solution mapper opb_solution) in + close_in opb_solution; + Some ret + with + | Unschedulable -> None;; + +let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = + if (get_max_latency previous_solution)>1 then + begin + Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); + flush stdout; + match scheduler + { problem with max_latency = (get_max_latency previous_solution)-1 } + with + | None -> previous_solution + | Some solution -> reoptimizing_scheduler scheduler solution problem + end + else previous_solution;; + +let smt_var i = Printf.sprintf "t%d" i + +let is_resource_used problem j = + try + Array.iter (fun usages -> + if usages.(j) > 0 + then raise Exit) problem.instruction_usages; + false + with Exit -> true;; + +let smt_use_quantifiers = false + +let smt_print_problem channel problem = + let nr_instructions = get_nr_instructions problem in + let gen_smt_resource_constraint time j = + output_string channel "(<= (+"; + Array.iteri + (fun i usages -> + let usage=usages.(j) in + if usage > 0 + then Printf.fprintf channel " (ite (= %s %s) %d 0)" + time (smt_var i) usage) + problem.instruction_usages; + Printf.fprintf channel ") %d)" problem.resource_bounds.(j) + in + output_string channel "(set-option :produce-models true)\n"; + for i=0 to nr_instructions + do + Printf.fprintf channel "(declare-const %s Int)\n" (smt_var i); + Printf.fprintf channel "(assert (>= %s 0))\n" (smt_var i) + done; + for i=0 to nr_instructions-1 + do + Printf.fprintf channel "(assert (< %s %s))\n" + (smt_var i) (smt_var nr_instructions) + done; + (if problem.max_latency > 0 + then Printf.fprintf channel "(assert (<= %s %d))\n" + (smt_var nr_instructions) problem.max_latency); + List.iter (fun ctr -> + Printf.fprintf channel "(assert (>= (- %s %s) %d))\n" + (smt_var ctr.instr_to) + (smt_var ctr.instr_from) + ctr.latency) problem.latency_constraints; + for j=0 to (Array.length problem.resource_bounds)-1 + do + if is_resource_used problem j + then + begin + if smt_use_quantifiers + then + begin + Printf.fprintf channel + "; resource #%d <= %d\n(assert (forall ((t Int)) " + j problem.resource_bounds.(j); + gen_smt_resource_constraint "t" j; + output_string channel "))\n" + end + else + begin + (if problem.max_latency < 0 + then failwith "quantifier explosion needs max latency"); + for t=0 to problem.max_latency + do + Printf.fprintf channel + "; resource #%d <= %d at t=%d\n(assert " + j problem.resource_bounds.(j) t; + gen_smt_resource_constraint (string_of_int t) j; + output_string channel ")\n" + done + end + end + done; + output_string channel "(check-sat)(get-model)\n";; + + +let ilp_print_problem channel problem pb_type = + let deadline = problem.max_latency in + assert (deadline > 0); + let nr_instructions = get_nr_instructions problem + and nr_resources = get_nr_resources problem + and successors = get_successors problem + and predecessors = get_predecessors problem in + let earliest_dates = get_earliest_dates predecessors + and latest_dates = get_latest_dates deadline successors in + + let pb_var i t = + Printf.sprintf "x%d_%d" i t in + + let gen_latency_constraint i_to i_from latency t_to = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_to; + Printf.fprintf channel "c_%d_%d_%d_%d: " + i_to i_from latency t_to; + for t_from=earliest_dates.(i_from) to + int_min latest_dates.(i_from) (t_to - latency) + do + Printf.fprintf channel "+1 %s " (pb_var i_from t_from) + done; + Printf.fprintf channel "-1 %s " (pb_var i_to t_to); + output_string channel ">= 0\n" + + and gen_dual_latency_constraint i_to i_from latency t_from = + Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" + i_to i_from latency i_to t_from; + Printf.fprintf channel "d_%d_%d_%d_%d: " + i_to i_from latency t_from; + for t_to=int_max earliest_dates.(i_to) (t_from + latency) + to latest_dates.(i_to) + do + Printf.fprintf channel "+1 %s " (pb_var i_to t_to) + done; + Printf.fprintf channel "-1 %s " (pb_var i_from t_from); + Printf.fprintf channel ">= 0\n" + + and gen_delta_constraint i_from i_to latency = + if delta_encoding + then Printf.fprintf channel "l_%d_%d_%d: +1 t%d -1 t%d >= %d\n" + i_from i_to latency i_to i_from latency + + in + + Printf.fprintf channel "\\ nr_instructions=%d deadline=%d\n" nr_instructions deadline; + begin + match pb_type with + | SATISFIABILITY -> output_string channel "Minimize dummy: 0\n" + | OPTIMIZATION -> + Printf.fprintf channel "Minimize\nmakespan: t%d\n" nr_instructions + end; + output_string channel "Subject To\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + Printf.fprintf channel "\\ t[%d] in %d..%d\ntimes%d: " i early late i; + for t=early to late + do + Printf.fprintf channel "+1 %s " (pb_var i t) + done; + Printf.fprintf channel "= 1\n" + done; + + for t=0 to deadline-1 + do + for j=0 to nr_resources-1 + do + let bound = problem.resource_bounds.(j) + and coeffs = ref [] in + for i=0 to nr_instructions-1 + do + let usage = problem.instruction_usages.(i).(j) in + if t >= earliest_dates.(i) && t <= latest_dates.(i) + && usage > 0 + then coeffs := (i, usage) :: !coeffs + done; + if !coeffs <> [] then + begin + Printf.fprintf channel "\\ resource #%d at t=%d <= %d\nr%d_%d: " j t bound j t; + List.iter (fun (i, usage) -> + Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; + Printf.fprintf channel ">= %d\n" (-bound) + end + done + done; + + List.iter + (fun ctr -> + if ctr.instr_to < nr_instructions then + begin + gen_delta_constraint ctr.instr_from ctr.instr_to ctr.latency; + begin + if direct_encoding + then + for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) + do + gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to + done + end; + begin + if reverse_encoding + then + for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) + do + gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from + done + end + end + ) problem.latency_constraints; + + begin + match pb_type with + | SATISFIABILITY -> () + | OPTIMIZATION -> + let final_latencies = Array.make nr_instructions 1 in + List.iter (fun (i, latency) -> + final_latencies.(i) <- int_max final_latencies.(i) latency) + predecessors.(nr_instructions); + for i_from = 0 to nr_instructions -1 + do + gen_delta_constraint i_from nr_instructions final_latencies.(i_from) + done; + for t_to=earliest_dates.(nr_instructions) to deadline + do + for i_from = 0 to nr_instructions -1 + do + gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to + done + done + end; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "ct%d : -1 t%d" i i; + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + Printf.fprintf channel " +%d %s" t (pb_var i t) + done; + output_string channel " = 0\n" + done; + output_string channel "Bounds\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + begin + Printf.fprintf channel "%d <= t%d <= %d\n" early i late; + if true then + for t=early to late do + Printf.fprintf channel "0 <= %s <= 1\n" (pb_var i t) + done + end + done; + output_string channel "Integer\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + Printf.fprintf channel "t%d " i + done; + output_string channel "\nBinary\n"; + for i=0 to (match pb_type with + | OPTIMIZATION -> nr_instructions + | SATISFIABILITY -> nr_instructions-1) + do + let early = earliest_dates.(i) and late= latest_dates.(i) in + for t=early to late do + output_string channel (pb_var i t); + output_string channel " " + done; + output_string channel "\n" + done; + output_string channel "End\n"; + { + mapper_pb_type = pb_type; + mapper_nr_instructions = nr_instructions; + mapper_nr_pb_variables = 0; + mapper_earliest_dates = earliest_dates; + mapper_latest_dates = latest_dates; + mapper_var_offsets = [| |]; + mapper_final_predecessors = predecessors.(nr_instructions) + };; + +(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) + +let positive_float_round x = truncate (x +. 0.5) + +let float_round (x : float) : int = + if x > 0.0 + then positive_float_round x + else - (positive_float_round (-. x)) + +let rounded_int_of_string x = float_round (float_of_string x) + +let ilp_read_solution mapper channel = + let times = Array.make + (match mapper.mapper_pb_type with + | OPTIMIZATION -> 1+mapper.mapper_nr_instructions + | SATISFIABILITY -> mapper.mapper_nr_instructions) (-1) in + try + while true do + let line = input_line channel in + ( if (String.length line) < 3 + then failwith (Printf.sprintf "bad ilp output: length(line) < 3: %s" line)); + match String.get line 0 with + | 'x' -> () + | 't' -> let space = + try String.index line ' ' + with Not_found -> + failwith "bad ilp output: no t variable number" + in + let tnumber = + try int_of_string (String.sub line 1 (space-1)) + with Failure _ -> + failwith "bad ilp output: not a variable number" + in + (if tnumber < 0 || tnumber >= (Array.length times) + then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); + let value = + let s = String.sub line (space+1) ((String.length line)-space-1) in + try rounded_int_of_string s + with Failure _ -> + failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) + in + (if value < 0 + then failwith "bad ilp output: negative time"); + times.(tnumber) <- value + | '#' -> () + | '0' -> () + | _ -> failwith (Printf.sprintf "bad ilp output: bad variable initial, line = %s" line) + done; + assert false + with End_of_file -> + Array.iteri (fun i x -> + if i<(Array.length times)-1 + && x<0 then raise Unschedulable) times; + times;; + +let ilp_solver = ref "ilp_solver" + +let problem_nr = ref 0 + +let ilp_scheduler pb_type problem = + try + let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr + and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in + incr problem_nr; + let opb_problem = open_out filename_in in + let mapper = ilp_print_problem opb_problem problem pb_type in + close_out opb_problem; + + begin + match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with + | Unix.WEXITED 0 -> + let opb_solution = open_in filename_out in + let ret = adjust_check_solution mapper (ilp_read_solution mapper opb_solution) in + close_in opb_solution; + Some ret + | Unix.WEXITED _ -> failwith "failed to start ilp solver" + | _ -> None + end + with + | Unschedulable -> None;; + +let current_utime_all () = + let t = Unix.times() in + t.Unix.tms_cutime +. t.Unix.tms_utime;; + +let utime_all_fn fn arg = + let utime_start = current_utime_all () in + let output = fn arg in + let utime_end = current_utime_all () in + (output, utime_end -. utime_start);; + +let cascaded_scheduler (problem : problem) = + let (some_initial_solution, list_scheduler_time) = + utime_all_fn (validated_scheduler list_scheduler) problem in + match some_initial_solution with + | None -> None + | Some initial_solution -> + let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in + begin + let latency2 = get_max_latency solution + and latency1 = get_max_latency initial_solution in + Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" + (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") + (get_nr_instructions problem) + latency1 latency2 + list_scheduler_time reoptimizing_time; + flush stdout + end; + Some solution;; + diff --git a/kvx/InstructionScheduler.mli b/kvx/InstructionScheduler.mli new file mode 100644 index 00000000..f91c2d06 --- /dev/null +++ b/kvx/InstructionScheduler.mli @@ -0,0 +1,110 @@ +(** Schedule instructions on a synchronized pipeline +by David Monniaux, CNRS, VERIMAG *) + +(** A latency constraint: instruction number [instr_to] should be scheduled at least [latency] clock ticks before [instr_from]. + +It is possible to specify [latency]=0, meaning that [instr_to] can be scheduled at the same clock tick as [instr_from], but not before. + +[instr_to] can be the special value equal to the number of instructions, meaning that it refers to the final output latency. *) +type latency_constraint = { + instr_from : int; + instr_to : int; + latency : int; + } + +(** A scheduling problem. + +In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. +*) +type problem = { + max_latency : int; + (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) + + resource_bounds : int array; + (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) + + instruction_usages: int array array; + (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) + + latency_constraints : latency_constraint list + (** The latency constraints that must be satisfied *) + };; + +(** Print problem for human readability. *) +val print_problem : out_channel -> problem -> unit;; + +(** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) +type solution = int array + +(** A scheduling algorithm. +The return value [Some x] is a solution [x]. +[None] means that scheduling failed. *) +type scheduler = problem -> solution option;; + +(* DISABLED +(** Schedule the problem optimally by constraint solving using the Gecode solver. *) +external gecode_scheduler : problem -> solution option + = "caml_gecode_schedule_instr" + *) + +(** Get the number the last scheduling time used for an instruction in a solution. +@return The last clock tick used *) +val maximum_slot_used : solution -> int + +(** Validate that a solution is truly a solution of a scheduling problem. +@raise Failure if validation fails *) +val check_schedule : problem -> solution -> unit + +(** Schedule the problem using a greedy list scheduling algorithm, from the start. +The first (according to instruction ordering) instruction that is ready (according to the latency constraints) is scheduled at the current clock tick. +Once a clock tick is full go to the next. + +@return [Some solution] when a solution is found, [None] if not. *) +val list_scheduler : problem -> solution option + +(** Schedule the problem using the order of instructions without any reordering *) +val greedy_scheduler : problem -> solution option + +(** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) +val schedule_reversed : scheduler -> problem -> int array option + +(** Schedule a problem from the end using a list scheduler. BUGGY *) +val reverse_list_scheduler : problem -> int array option + +(** Check that a problem is well-formed. +@raise Failure if validation fails *) +val check_problem : problem -> unit + +(** Apply a scheduler and validate the result against the input problem. +@return The solution found +@raise Failure if validation fails *) +val validated_scheduler : scheduler -> problem -> solution option;; + +(** Get max latency from solution +@return Max latency *) +val get_max_latency : solution -> int;; + +(** Get the length of a maximal critical path +@return Max length *) +val maximum_critical_path : problem -> int;; + +(** Apply line scheduler then advanced solver +@return A solution if found *) +val cascaded_scheduler : problem -> solution option;; + +val show_date_ranges : problem -> unit;; + +type pseudo_boolean_problem_type = + | SATISFIABILITY + | OPTIMIZATION;; + +type pseudo_boolean_mapper +val pseudo_boolean_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; +val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> solution;; +val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; + +val smt_print_problem : out_channel -> problem -> unit;; + +val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; + +val ilp_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; diff --git a/kvx/Machregs.v b/kvx/Machregs.v new file mode 100644 index 00000000..02fa4e6b --- /dev/null +++ b/kvx/Machregs.v @@ -0,0 +1,245 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import String. +Require Import Coqlib. +Require Import Decidableplus. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Op. + +(** ** Machine registers *) + +(** The following type defines the machine registers that can be referenced + as locations. These include: +- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). +- Floating-point registers that can be allocated to RTL pseudo-registers + ([Fxx]). + + The type [mreg] does not include reserved machine registers such as + the zero register (x0), the link register (x1), the stack pointer + (x2), the global pointer (x3), and the thread pointer (x4). + Finally, register x31 is reserved for use as a temporary by the + assembly-code generator [Asmgen]. +*) + +Inductive mreg: Type := + (* Allocatable General Purpose regs. *) + | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 + | R10 | R11 (* | R12 | R13 | R14 *) | R15 (* | R16 *) | R17 | R18 | R19 + | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 + | R30 | R31 (* | R32 *) | R33 | R34 | R35 | R36 | R37 | R38 | R39 + | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 + | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 + | R60 | R61 | R62 | R63. + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Defined. +Global Opaque mreg_eq. + +Definition all_mregs := + R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 + :: R10 :: R11 (* :: R12 :: R13 :: R14 *) :: R15 (* :: R16 *) :: R17 :: R18 :: R19 + :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 + :: R30 :: R31 (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 + :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 + :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 + :: R60 :: R61 :: R62 :: R63 :: nil. + +Lemma all_mregs_complete: + forall (r: mreg), In r all_mregs. +Proof. + assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). + intros. specialize (H r). InvBooleans. auto. +Qed. + +Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. + +Instance Finite_mreg : Finite mreg := { + Finite_elements := all_mregs; + Finite_elements_spec := all_mregs_complete +}. + +Definition mreg_type (r: mreg): typ := Tany64. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + Definition eq := mreg_eq. + Definition index (r: mreg): positive := + match r with + | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 + | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 + | R10 => 11 | R11 => 12 (* | R12 => 13 | R13 => 14 | R14 => 15 *) + | R15 => 16 (* | R16 => 17 *) | R17 => 18 | R18 => 19 | R19 => 20 + | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 + | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 + | R30 => 31 | R31 => 32 (* | R32 => 33 *) | R33 => 34 | R34 => 35 + | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 + | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 + | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 + | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 + | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 + | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 + end. + + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + decide_goal. + Qed. +End IndexedMreg. + +Definition is_stack_reg (r: mreg) : bool := false. + +(** ** Names of registers *) + +Local Open Scope string_scope. + +Definition register_names := + ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) + :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R8" , R8) :: ("R9" , R9) + :: ("R10", R10) :: ("R11", R11) (* :: ("R12", R12) :: ("R13", R13) :: ("R14", R14) *) + :: ("R15", R15) (* :: ("R16", R16) *) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) + :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) + :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) + :: ("R30", R30) :: ("R31", R31) (* :: ("R32", R32) *) :: ("R33", R33) :: ("R34", R34) + :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) + :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) + :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) + :: ("R50", R50) :: ("R51", R51) :: ("R52", R52) :: ("R53", R53) :: ("R54", R54) + :: ("R55", R55) :: ("R56", R56) :: ("R57", R57) :: ("R58", R58) :: ("R59", R59) + :: ("R60", R60) :: ("R61", R61) :: ("R62", R62) :: ("R63", R63) :: nil. + +Definition register_by_name (s: string) : option mreg := + let fix assoc (l: list (string * mreg)) : option mreg := + match l with + | nil => None + | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' + end + in assoc register_names. + +(** ** Destroyed registers, preferred registers *) + +Definition destroyed_by_op (op: operation): list mreg := nil. +(*match op with + | Ointoffloat | Ointuoffloat | Ointofsingle | Ointuofsingle + | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle + => F6 :: nil + | _ => nil + end. +*) + +Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := nil. + +Definition destroyed_by_cond (cond: condition): list mreg := nil. + +Definition destroyed_by_jumptable: list mreg := R62 :: R63 :: nil. + +Fixpoint destroyed_by_clobber (cl: list string): list mreg := + match cl with + | nil => nil + | c1 :: cl => + match register_by_name c1 with + | Some r => r :: destroyed_by_clobber cl + | None => destroyed_by_clobber cl + end + end. + +Definition destroyed_by_builtin (ef: external_function): list mreg := + match ef with + | EF_inline_asm txt sg clob => destroyed_by_clobber clob + | EF_memcpy sz al => + if Z.leb sz 15 + then R62 :: R63 :: R61 :: nil + else R62 :: R63 :: R61 :: R60 :: nil + | EF_profiling _ _ => R62 :: R63 ::nil + | _ => nil + end. + +Definition destroyed_by_setstack (ty: typ): list mreg := nil. + +Definition destroyed_at_function_entry: list mreg := R17 :: nil. + +Definition temp_for_parent_frame: mreg := R17. (* Temporary used to store the parent frame, where the arguments are *) + +Definition destroyed_at_indirect_call: list mreg := nil. + (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) + +Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). + +(* FIXME DMonniaux this seems to be the place for preferred registers for arguments *) +Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). + + (* match ef with + | EF_builtin name sg => + if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then + (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) + else + (nil, nil) + | _ => + (nil, nil) + end. *) + +Global Opaque + destroyed_by_op destroyed_by_load destroyed_by_store + destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin + destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame + mregs_for_operation mregs_for_builtin. + +(** Two-address operations. Return [true] if the first argument and + the result must be in the same location *and* are unconstrained + by [mregs_for_operation]. There are two: the pseudo [Ocast32signed], + because it expands to a no-op owing to the representation of 32-bit + integers as their 64-bit sign extension; and [Ocast32unsigned], + because it builds on the same magic no-op. *) + +Definition two_address_op (op: operation) : bool := + match op with + | Ofmaddf | Ofmaddfs + | Ofmsubf | Ofmsubfs + | Omadd | Omaddimm _ + | Omaddl | Omaddlimm _ + | Omsub | Omsubl + | Osel _ _ | Oselimm _ _ | Osellimm _ _ + | Oinsf _ _ | Oinsfl _ _ => true + | _ => false + end. + +(** Constraints on constant propagation for builtins *) + +Definition builtin_constraints (ef: external_function) : + list builtin_arg_constraint := + match ef with + | EF_builtin id sg => + if string_dec id "__builtin_kvx_get" then OK_const :: nil + else if string_dec id "__builtin_kvx_set" + then OK_const :: OK_default :: nil + else if string_dec id "__builtin_kvx_wfxl" + then OK_const :: OK_default :: nil + else if string_dec id "__builtin_kvx_wfxm" + then OK_const :: OK_default :: nil + else nil + | EF_vload _ => OK_addressing :: nil + | EF_vstore _ => OK_addressing :: OK_default :: nil + | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil + | EF_annot kind txt targs => map (fun _ => OK_all) targs + | EF_debug kind txt targs => map (fun _ => OK_all) targs + | _ => nil + end. diff --git a/kvx/Machregsaux.ml b/kvx/Machregsaux.ml new file mode 100644 index 00000000..76956959 --- /dev/null +++ b/kvx/Machregsaux.ml @@ -0,0 +1,41 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Auxiliary functions on machine registers *) + +open Camlcoq +open Machregs + +let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 + +let _ = + List.iter + (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) + Machregs.register_names + +let is_scratch_register r = false + +let name_of_register r = + try Some (Hashtbl.find register_names r) with Not_found -> None + +let register_by_name s = + Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) + +let can_reserve_register r = Conventions1.is_callee_save r + +let class_of_type = function + | AST.Tint | AST.Tlong + | AST.Tfloat | AST.Tsingle -> 0 + | AST.Tany32 | AST.Tany64 -> assert false diff --git a/kvx/Machregsaux.mli b/kvx/Machregsaux.mli new file mode 100644 index 00000000..d7117c21 --- /dev/null +++ b/kvx/Machregsaux.mli @@ -0,0 +1,20 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Auxiliary functions on machine registers *) + +val name_of_register: Machregs.mreg -> string option +val register_by_name: string -> Machregs.mreg option +val is_scratch_register: string -> bool +val can_reserve_register: Machregs.mreg -> bool + +val class_of_type: AST.typ -> int diff --git a/kvx/NeedOp.v b/kvx/NeedOp.v new file mode 100644 index 00000000..4c354d5a --- /dev/null +++ b/kvx/NeedOp.v @@ -0,0 +1,414 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import AST Integers Floats. +Require Import Values Memory Globalenvs. +Require Import Op RTL. +Require Import NeedDomain. + +(** Neededness analysis for RISC-V operators *) + +Definition op1 (nv: nval) := nv :: nil. +Definition op2 (nv: nval) := nv :: nv :: nil. +Definition op3 (nv: nval) := nv :: nv :: nv :: nil. + +Definition needs_of_condition (cond: condition): list nval := nil. +Definition needs_of_condition0 (cond0: condition0): list nval := nil. + +Definition needs_of_operation (op: operation) (nv: nval): list nval := + match op with + | Omove => op1 nv + | Ointconst n => nil + | Olongconst n => nil + | Ofloatconst n => nil + | Osingleconst n => nil + | Oaddrsymbol id ofs => nil + | Oaddrstack ofs => nil + | Ocast8signed => op1 (sign_ext 8 nv) + | Ocast16signed => op1 (sign_ext 16 nv) + | Oadd => op2 (modarith nv) + | Oaddimm n => op1 (modarith nv) + | Oaddx _ => op2 (default nv) + | Oaddximm _ _ => op1 (default nv) + | Oneg => op1 (modarith nv) + | Osub => op2 (default nv) + | Orevsubimm _ => op1 (default nv) + | Orevsubx _ => op2 (default nv) + | Orevsubximm _ _ => op1 (default nv) + | Omul => op2 (modarith nv) + | Omulimm _ => op1 (modarith nv) + | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) + | Oand => op2 (bitwise nv) + | Oandimm n => op1 (andimm nv n) + | Onand => op2 (bitwise nv) + | Onandimm n => op1 (andimm nv n) + | Oor => op2 (bitwise nv) + | Oorimm n => op1 (orimm nv n) + | Onor => op2 (bitwise nv) + | Onorimm n => op1 (orimm nv n) + | Oxor => op2 (bitwise nv) + | Oxorimm n => op1 (bitwise nv) + | Onxor => op2 (bitwise nv) + | Onxorimm n => op1 (bitwise nv) + | Onot => op1 (bitwise nv) + | Oandn => op2 (bitwise nv) + | Oandnimm n => op1 (andimm nv n) + | Oorn => op2 (bitwise nv) + | Oornimm n => op1 (orimm nv n) + | Oshl | Oshr | Oshru => op2 (default nv) + | Oshlimm n => op1 (shlimm nv n) + | Oshrimm n => op1 (shrimm nv n) + | Ororimm n => op1 (ror nv n) + | Oshruimm n => op1 (shruimm nv n) + | Oshrximm n => op1 (default nv) + | Omadd => op3 (modarith nv) + | Omaddimm n => op2 (modarith nv) + | Omsub => op3 (modarith nv) + | Omakelong => op2 (default nv) + | Olowlong | Ohighlong => op1 (default nv) + | Ocast32signed => op1 (default nv) + | Ocast32unsigned => op1 (default nv) + | Oaddl => op2 (default nv) + | Oaddlimm n => op1 (default nv) + | Oaddxl _ => op2 (default nv) + | Oaddxlimm _ _ => op1 (default nv) + | Orevsublimm _ => op1 (default nv) + | Orevsubxl _ => op2 (default nv) + | Orevsubxlimm _ _ => op1 (default nv) + | Onegl => op1 (default nv) + | Osubl => op2 (default nv) + | Omull => op2 (default nv) + | Omullimm _ => op1 (default nv) + | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) + | Oandl => op2 (default nv) + | Oandlimm n => op1 (default nv) + | Onandl => op2 (default nv) + | Onandlimm n => op1 (default nv) + | Oorl => op2 (default nv) + | Oorlimm n => op1 (default nv) + | Onorl => op2 (default nv) + | Onorlimm n => op1 (default nv) + | Oxorl => op2 (default nv) + | Oxorlimm n => op1 (default nv) + | Onxorl => op2 (default nv) + | Onxorlimm n => op1 (default nv) + | Onotl => op1 (default nv) + | Oandnl => op2 (default nv) + | Oandnlimm n => op1 (default nv) + | Oornl => op2 (default nv) + | Oornlimm n => op1 (default nv) + | Oshll | Oshrl | Oshrlu => op2 (default nv) + | Oshllimm n => op1 (default nv) + | Oshrlimm n => op1 (default nv) + | Oshrluimm n => op1 (default nv) + | Oshrxlimm n => op1 (default nv) + | Omaddl => op3 (default nv) + | Omaddlimm n => op2 (default nv) + | Omsubl => op3 (default nv) + | Onegf | Oabsf => op1 (default nv) + | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) + | Ofmaddf | Ofmsubf => op3 (default nv) + | Onegfs | Oabsfs => op1 (default nv) + | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) + | Oinvfs => op1 (default nv) + | Ofmaddfs | Ofmsubfs => op3 (default nv) + | Ofloatofsingle | Osingleoffloat => op1 (default nv) + | Ointoffloat | Ointuoffloat => op1 (default nv) + | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) + | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) + | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) + | Ocmp c => needs_of_condition c + | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) + | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) + | Osel c ty => nv :: nv :: needs_of_condition0 c + | Oselimm c imm + | Osellimm c imm => nv :: needs_of_condition0 c + end. + +Definition operation_is_redundant (op: operation) (nv: nval): bool := + match op with + | Ocast8signed => sign_ext_redundant 8 nv + | Ocast16signed => sign_ext_redundant 16 nv + | Oandimm n => andimm_redundant nv n + | Oorimm n => orimm_redundant nv n + | _ => false + end. + +Ltac InvAgree := + match goal with + | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree + | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree + | _ => idtac + end. + +Ltac TrivialExists := + match goal with + | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto + | _ => idtac + end. + +Section SOUNDNESS. + +Variable ge: genv. +Variable sp: block. +Variables m1 m2: mem. +Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p. + +Lemma needs_of_condition_sound: + forall cond args b args', + eval_condition cond args m1 = Some b -> + vagree_list args args' (needs_of_condition cond) -> + eval_condition cond args' m2 = Some b. +Proof. + intros. unfold needs_of_condition in H0. + eapply default_needs_of_condition_sound; eauto. +Qed. + +Let valid_pointer_inj: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. + rewrite Mem.valid_pointer_nonempty_perm in *. eauto. +Qed. + +Let weak_valid_pointer_inj: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. + rewrite Mem.weak_valid_pointer_spec in *. + rewrite ! Mem.valid_pointer_nonempty_perm in *. + destruct H0; [left|right]; eauto. +Qed. + +Let weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + inject_id b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + unfold inject_id; intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Let valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + inject_id b1 = Some (b1', delta1) -> + inject_id b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + unfold inject_id; intros. left; congruence. +Qed. + +Lemma needs_of_condition0_sound: + forall cond arg1 b arg2, + eval_condition0 cond arg1 m1 = Some b -> + vagree arg1 arg2 All -> + eval_condition0 cond arg2 m2 = Some b. +Proof. + intros until arg2. + intros Hcond Hagree. + apply eval_condition0_inj with (f := inject_id) (m1 := m1) (v1 := arg1); simpl; auto. + apply val_inject_lessdef. apply lessdef_vagree. assumption. +Qed. + +Lemma addl_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.addl v1 v2) (Val.addl w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.addl. + destruct v1; destruct v2; trivial; destruct Archi.ptr64; trivial. + - apply Val.addl_lessdef; trivial. +Qed. + +Lemma subl_lessdef: + forall v1 v1' v2 v2', + Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Val.lessdef (Val.subl v1 v2) (Val.subl v1' v2'). +Proof. + intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. +Qed. + +Lemma subl_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.subl v1 v2) (Val.subl w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.subl. + destruct v1; destruct v2; trivial; destruct Archi.ptr64; simpl; trivial. + destruct (eq_block _ _) ; simpl; trivial. + - apply subl_lessdef; trivial. +Qed. + + +Lemma mull_sound: + forall v1 w1 v2 w2 x, + vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> + vagree (Val.mull v1 v2) (Val.mull w1 w2) x. +Proof. + unfold default; intros. + destruct x; simpl in *; trivial. + - unfold Val.mull. + destruct v1; destruct v2; trivial. + - unfold Val.mull. + destruct v1; destruct v2; trivial. + inv H. inv H0. + trivial. +Qed. + + +Remark default_idem: forall nv, default (default nv) = default nv. +Proof. + destruct nv; simpl; trivial. +Qed. + +Lemma vagree_triple_op_float : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_float f a b c) + (ExtValues.triple_op_float f x y z) nv). +Proof. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. +Qed. + +Lemma vagree_triple_op_single : + forall f a b c x y z nv, + (vagree a x (default nv)) -> + (vagree b y (default nv)) -> + (vagree c z (default nv)) -> + (vagree (ExtValues.triple_op_single f a b c) + (ExtValues.triple_op_single f x y z) nv). +Proof. + induction nv; + intros Hax Hby Hcz. + - trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + - simpl in *. destruct a; simpl; trivial. + destruct b; simpl; trivial. + destruct c; simpl; trivial. + inv Hax. inv Hby. inv Hcz. + simpl. + constructor. +Qed. + +Hint Resolve vagree_triple_op_float vagree_triple_op_single : na. + +Lemma needs_of_operation_sound: + forall op args v nv args', + eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> + vagree_list args args' (needs_of_operation op nv) -> + nv <> Nothing -> + exists v', + eval_operation ge (Vptr sp Ptrofs.zero) op args' m2 = Some v' + /\ vagree v v' nv. +Proof. + unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); + simpl in *; FuncInv; InvAgree; TrivialExists. +- apply sign_ext_sound; auto. compute; auto. +- apply sign_ext_sound; auto. compute; auto. +- apply add_sound; auto. +- apply add_sound; auto with na. +- apply neg_sound; auto. +- apply mul_sound; auto. +- apply mul_sound; auto with na. +- apply and_sound; auto. +- apply andimm_sound; auto. +- apply notint_sound; apply and_sound; auto. +- apply notint_sound; apply andimm_sound; auto. +- apply or_sound; auto. +- apply orimm_sound; auto. +- apply notint_sound; apply or_sound; auto. +- apply notint_sound; apply orimm_sound; auto. +- apply xor_sound; auto. +- apply xor_sound; auto with na. +- apply notint_sound; apply xor_sound; auto. +- apply notint_sound; apply xor_sound; auto with na. +- apply notint_sound; auto. +- apply and_sound; try apply notint_sound; auto with na. +- apply andimm_sound; try apply notint_sound; auto with na. +- apply or_sound; try apply notint_sound; auto with na. +- apply orimm_sound; try apply notint_sound; auto with na. +- apply shlimm_sound; auto. +- apply shrimm_sound; auto. +- apply shruimm_sound; auto. +- apply ror_sound; auto. + (* madd *) +- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. +- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. +- repeat rewrite ExtValues.sub_add_neg. + apply add_sound; trivial. + apply neg_sound; trivial. + rewrite modarith_idem. + apply mul_sound; + rewrite modarith_idem; trivial. +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto. + simpl; auto with na. + (* select imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. + (* select long imm *) +- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. + { erewrite needs_of_condition0_sound by eauto. + apply select_sound; auto with na. } + simpl; auto with na. +Qed. + +Lemma operation_is_redundant_sound: + forall op nv arg1 args v arg1' args', + operation_is_redundant op nv = true -> + eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m1 = Some v -> + vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> + vagree v arg1' nv. +Proof. + intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. +- apply sign_ext_redundant_sound; auto. omega. +- apply sign_ext_redundant_sound; auto. omega. +- apply andimm_redundant_sound; auto. +- apply orimm_redundant_sound; auto. +Qed. + +End SOUNDNESS. diff --git a/kvx/Op.v b/kvx/Op.v new file mode 100644 index 00000000..544bb081 --- /dev/null +++ b/kvx/Op.v @@ -0,0 +1,1975 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + semantics for the CminorSel, RTL, LTL and Mach languages depend on the + following types, defined in this library: +- [condition]: boolean conditions for conditional branches; +- [operation]: arithmetic and logical operations; +- [addressing]: addressing modes for load and store operations. + + These types are processor-specific and correspond roughly to what the + processor can compute in one instruction. In other terms, these + types reflect the state of the program after instruction selection. + For a processor-independent set of operations, see the abstract + syntax and dynamic semantics of the Cminor language. +*) + +Require Import BoolEqual Coqlib. +Require Import AST Integers Floats. +Require Import Values ExtValues Memory Globalenvs Events. + +Set Implicit Arguments. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Type := + | Ccomp (c: comparison) (**r signed integer comparison *) + | Ccompu (c: comparison) (**r unsigned integer comparison *) + | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) + | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) + | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) + | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) + | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) + | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) + | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) + | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) + | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) + | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) + +Inductive condition0 : Type := + | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) + | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) + | Ccompl0 (c: comparison) (**r signed 64-bit integer comparison with 0 *) + | Ccomplu0 (c: comparison). (**r unsigned 64-bit integer comparison with 0 *) + +Definition arg_type_of_condition0 (cond: condition0) := + match cond with + | Ccomp0 _ | Ccompu0 _ => Tint + | Ccompl0 _ | Ccomplu0 _ => Tlong + end. + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Type := + | Omove (**r [rd = r1] *) + | Ointconst (n: int) (**r [rd] is set to the given integer constant *) + | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) + | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) + | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) + | Oaddrsymbol (id: ident) (ofs: ptrofs) (**r [rd] is set to the address of the symbol plus the given offset *) + | Oaddrstack (ofs: ptrofs) (**r [rd] is set to the stack pointer plus the given offset *) +(*c 32-bit integer arithmetic: *) + | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) + | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) + | Oadd (**r [rd = r1 + r2] *) + | Oaddimm (n: int) (**r [rd = r1 + n] *) + | Oaddx (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddximm (shift: shift1_4) (n: int) (**r [rd = r1 << shift + n] *) + | Oneg (**r [rd = - r1] *) + | Osub (**r [rd = r1 - r2] *) + | Orevsubimm (n: int) (**r [rd = n - r1] *) + | Orevsubx (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubximm (shift: shift1_4) (n: int) (**r [rd = n -r1 << shift] *) + | Omul (**r [rd = r1 * r2] *) + | Omulimm (n: int) (**r [rd = r1 * n] *) + | Omulhs (**r [rd = high part of r1 * r2, signed] *) + | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odiv (**r [rd = r1 / r2] (signed) *) + | Odivu (**r [rd = r1 / r2] (unsigned) *) + | Omod (**r [rd = r1 % r2] (signed) *) + | Omodu (**r [rd = r1 % r2] (unsigned) *) + | Oand (**r [rd = r1 & r2] *) + | Oandimm (n: int) (**r [rd = r1 & n] *) + | Onand (**r [rd = ~(r1 & r2)] *) + | Onandimm (n: int) (**r [rd = ~(r1 & n)] *) + | Oor (**r [rd = r1 | r2] *) + | Oorimm (n: int) (**r [rd = r1 | n] *) + | Onor (**r [rd = ~(r1 | r2)] *) + | Onorimm (n: int) (**r [rd = ~(r1 | n)] *) + | Oxor (**r [rd = r1 ^ r2] *) + | Oxorimm (n: int) (**r [rd = r1 ^ n] *) + | Onxor (**r [rd = ~(r1 ^ r2)] *) + | Onxorimm (n: int) (**r [rd = ~(r1 ^ n)] *) + | Onot (**r [rd = ~r1] *) + | Oandn (**r [rd = (~r1) & r2] *) + | Oandnimm (n: int) (**r [rd = (~r1) & n] *) + | Oorn (**r [rd = (~r1) | r2] *) + | Oornimm (n: int) (**r [rd = (~r1) | n] *) + | Oshl (**r [rd = r1 << r2] *) + | Oshlimm (n: int) (**r [rd = r1 << n] *) + | Oshr (**r [rd = r1 >>s r2] (signed) *) + | Oshrimm (n: int) (**r [rd = r1 >>s n] (signed) *) + | Oshru (**r [rd = r1 >>u r2] (unsigned) *) + | Oshruimm (n: int) (**r [rd = r1 >>x n] (unsigned) *) + | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Ororimm (n: int) (**r rotate right immediate *) + | Omadd (**r [rd = rd + r1 * r2] *) + | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) + | Omsub (**r [rd = rd - r1 * r2] *) +(*c 64-bit integer arithmetic: *) + | Omakelong (**r [rd = r1 << 32 | r2] *) + | Olowlong (**r [rd = low-word(r1)] *) + | Ohighlong (**r [rd = high-word(r1)] *) + | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) + | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) + | Oaddl (**r [rd = r1 + r2] *) + | Oaddlimm (n: int64) (**r [rd = r1 + n] *) + | Oaddxl (shift: shift1_4) (**r [rd = r1 << shift + r2] *) + | Oaddxlimm (shift: shift1_4) (n: int64) (**r [rd = r1 << shift + n] *) + | Orevsublimm (n: int64) (**r [rd = n - r1] *) + | Orevsubxl (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) + | Orevsubxlimm (shift: shift1_4) (n: int64) (**r [rd = n -r1 << shift] *) + | Onegl (**r [rd = - r1] *) + | Osubl (**r [rd = r1 - r2] *) + | Omull (**r [rd = r1 * r2] *) + | Omullimm (n: int64) (**r [rd = r1 * n] *) + | Omullhs (**r [rd = high part of r1 * r2, signed] *) + | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) + | Odivl (**r [rd = r1 / r2] (signed) *) + | Odivlu (**r [rd = r1 / r2] (unsigned) *) + | Omodl (**r [rd = r1 % r2] (signed) *) + | Omodlu (**r [rd = r1 % r2] (unsigned) *) + | Oandl (**r [rd = r1 & r2] *) + | Oandlimm (n: int64) (**r [rd = r1 & n] *) + | Onandl (**r [rd = ~(r1 & r2)] *) + | Onandlimm (n: int64) (**r [rd = ~(r1 & n)] *) + | Oorl (**r [rd = r1 | r2] *) + | Oorlimm (n: int64) (**r [rd = r1 | n] *) + | Onorl (**r [rd = ~(r1 | r2)] *) + | Onorlimm (n: int64) (**r [rd = ~(r1 | n)] *) + | Oxorl (**r [rd = r1 ^ r2] *) + | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) + | Onxorl (**r [rd = ~(r1 ^ r2)] *) + | Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *) + | Onotl (**r [rd = ~r1] *) + | Oandnl (**r [rd = (~r1) & r2] *) + | Oandnlimm (n: int64) (**r [rd = (~r1) & n] *) + | Oornl (**r [rd = (~r1) | r2] *) + | Oornlimm (n: int64) (**r [rd = (~r1) | n] *) + | Oshll (**r [rd = r1 << r2] *) + | Oshllimm (n: int) (**r [rd = r1 << n] *) + | Oshrl (**r [rd = r1 >> r2] (signed) *) + | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) + | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) + | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) + | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) + | Omaddl (**r [rd = rd + r1 * r2] *) + | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) + | Omsubl (**r [rd = rd - r1 * r2] *) +(*c Floating-point arithmetic: *) + | Onegf (**r [rd = - r1] *) + | Oabsf (**r [rd = abs(r1)] *) + | Oaddf (**r [rd = r1 + r2] *) + | Osubf (**r [rd = r1 - r2] *) + | Omulf (**r [rd = r1 * r2] *) + | Odivf (**r [rd = r1 / r2] *) + | Ominf + | Omaxf + | Ofmaddf + | Ofmsubf + | Onegfs (**r [rd = - r1] *) + | Oabsfs (**r [rd = abs(r1)] *) + | Oaddfs (**r [rd = r1 + r2] *) + | Osubfs (**r [rd = r1 - r2] *) + | Omulfs (**r [rd = r1 * r2] *) + | Odivfs (**r [rd = r1 / r2] *) + | Ominfs + | Omaxfs + | Oinvfs + | Ofmaddfs + | Ofmsubfs + | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) + | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) + | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *) + | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) + | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *) + | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) + | Osingleofintu (**r [rd = float32_of_unsigned_int(r1)] *) + | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) + | Olonguoffloat (**r [rd = unsigned_long_of_float64(r1)] *) + | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) + | Ofloatoflongu (**r [rd = float64_of_unsigned_long(r1)] *) + | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) + | Olonguofsingle (**r [rd = unsigned_long_of_float32(r1)] *) + | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) + | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + | Oextfz (stop : Z) (start : Z) + | Oextfs (stop : Z) (start : Z) + | Oextfzl (stop : Z) (start : Z) + | Oextfsl (stop : Z) (start : Z) + | Oinsf (stop : Z) (start : Z) + | Oinsfl (stop : Z) (start : Z) + | Osel (c0 : condition0) (ty : typ) + | Oselimm (c0 : condition0) (imm: int) + | Osellimm (c0 : condition0) (imm: int64). + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Type := + | Aindexed2XS (scale : Z) : addressing (**r Address is [r1 + r2 << scale] *) + | Aindexed2 : addressing (**r Address is [r1 + r2] *) + | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) + | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) + | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in modules [CSE] and [Allocation]). *) + +Definition eq_condition (x y: condition) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + +Definition eq_condition0 (x y: condition0) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec Int64.eq_dec; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + decide equality. +Defined. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize ident_eq Ptrofs.eq_dec Z.eq_dec; intros. + decide equality. +Defined. + +Definition eq_shift1_4 (x y : shift1_4): {x=y} + {x<>y}. +Proof. + decide equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + generalize typ_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. + decide equality. +Defined. + +(* Alternate definition: +Definition beq_operation: forall (x y: operation), bool. +Proof. + generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; boolean_equality. +Defined. + +Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. +Proof. + decidable_equality_from beq_operation. +Defined. +*) + +Global Opaque eq_condition eq_addressing eq_operation. + +(** * Evaluation functions *) + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation can trigger an + error, e.g. integer division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 + | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) + | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) + | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 + | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) + | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) + | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) + | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) + | _, _ => None + end. + +Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := + match cond with + | Ccomp0 c => Val.cmp_bool c v1 (Vint Int.zero) + | Ccompu0 c => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint Int.zero) + | Ccompl0 c => Val.cmpl_bool c v1 (Vlong Int64.zero) + | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) + end. + +Definition negate_condition0 (cond0 : condition0) : condition0 := + match cond0 with + | Ccomp0 c => Ccomp0 (negate_comparison c) + | Ccompu0 c => Ccompu0 (negate_comparison c) + | Ccompl0 c => Ccompl0 (negate_comparison c) + | Ccomplu0 c => Ccomplu0 (negate_comparison c) + end. + +Definition eval_operation + (F V: Type) (genv: Genv.t F V) (sp: val) + (op: operation) (vl: list val) (m: mem): option val := + match op, vl with + | Omove, v1::nil => Some v1 + | Ointconst n, nil => Some (Vint n) + | Olongconst n, nil => Some (Vlong n) + | Ofloatconst n, nil => Some (Vfloat n) + | Osingleconst n, nil => Some (Vsingle n) + | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) + | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) + | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) + | Oaddx s14, v1 :: v2 :: nil => Some (addx (int_of_shift1_4 s14) v1 v2) + | Oaddximm s14 n, v1 :: nil => Some (addx (int_of_shift1_4 s14) v1 (Vint n)) + | Oneg, v1 :: nil => Some (Val.neg v1) + | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) + | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) + | Orevsubx shift, v1 :: v2 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 v2) + | Orevsubximm shift n, v1 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 (Vint n)) + | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) + | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) + | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) + | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) + | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 + | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 + | Omod, v1 :: v2 :: nil => Val.mods v1 v2 + | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 + | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) + | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) + | Onand, v1 :: v2 :: nil => Some (Val.notint (Val.and v1 v2)) + | Onandimm n, v1 :: nil => Some (Val.notint (Val.and v1 (Vint n))) + | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) + | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) + | Onor, v1 :: v2 :: nil => Some (Val.notint (Val.or v1 v2)) + | Onorimm n, v1 :: nil => Some (Val.notint (Val.or v1 (Vint n))) + | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) + | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) + | Onxor, v1 :: v2 :: nil => Some (Val.notint (Val.xor v1 v2)) + | Onxorimm n, v1 :: nil => Some (Val.notint (Val.xor v1 (Vint n))) + | Onot, v1 :: nil => Some (Val.notint v1) + | Oandn, v1 :: v2 :: nil => Some (Val.and (Val.notint v1) v2) + | Oandnimm n, v1 :: nil => Some (Val.and (Val.notint v1) (Vint n)) + | Oorn, v1 :: v2 :: nil => Some (Val.or (Val.notint v1) v2) + | Oornimm n, v1 :: nil => Some (Val.or (Val.notint v1) (Vint n)) + | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) + | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) + | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) + | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) + | Ororimm n, v1 :: nil => Some (Val.ror v1 (Vint n)) + | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) + | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) + | Oshrximm n, v1::nil => Some (Val.maketotal (Val.shrx v1 (Vint n))) + | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) + | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) + | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) + + | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) + | Olowlong, v1::nil => Some (Val.loword v1) + | Ohighlong, v1::nil => Some (Val.hiword v1) + | Ocast32signed, v1 :: nil => Some (Val.longofint v1) + | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) + | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) + | Oaddxl s14, v1 :: v2 :: nil => Some (addxl (int_of_shift1_4 s14) v1 v2) + | Oaddxlimm s14 n, v1 :: nil => Some (addxl (int_of_shift1_4 s14) v1 (Vlong n)) + | Onegl, v1::nil => Some (Val.negl v1) + | Osubl, v1::v2::nil => Some (Val.subl v1 v2) + | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) + | Orevsubxl shift, v1 :: v2 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2) + | Orevsubxlimm shift n, v1 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 (Vlong n)) + | Omull, v1::v2::nil => Some (Val.mull v1 v2) + | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) + | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) + | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) + | Odivl, v1::v2::nil => Val.divls v1 v2 + | Odivlu, v1::v2::nil => Val.divlu v1 v2 + | Omodl, v1::v2::nil => Val.modls v1 v2 + | Omodlu, v1::v2::nil => Val.modlu v1 v2 + | Oandl, v1::v2::nil => Some(Val.andl v1 v2) + | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) + | Onandl, v1::v2::nil => Some(Val.notl (Val.andl v1 v2)) + | Onandlimm n, v1::nil => Some(Val.notl (Val.andl v1 (Vlong n))) + | Oorl, v1::v2::nil => Some(Val.orl v1 v2) + | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) + | Onorl, v1::v2::nil => Some(Val.notl (Val.orl v1 v2)) + | Onorlimm n, v1::nil => Some(Val.notl (Val.orl v1 (Vlong n))) + | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) + | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) + | Onxorl, v1::v2::nil => Some(Val.notl (Val.xorl v1 v2)) + | Onxorlimm n, v1::nil => Some(Val.notl (Val.xorl v1 (Vlong n))) + | Onotl, v1 :: nil => Some (Val.notl v1) + | Oandnl, v1 :: v2 :: nil => Some (Val.andl (Val.notl v1) v2) + | Oandnlimm n, v1 :: nil => Some (Val.andl (Val.notl v1) (Vlong n)) + | Oornl, v1 :: v2 :: nil => Some (Val.orl (Val.notl v1) v2) + | Oornlimm n, v1 :: nil => Some (Val.orl (Val.notl v1) (Vlong n)) + | Oshll, v1::v2::nil => Some (Val.shll v1 v2) + | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) + | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) + | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) + | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) + | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) + | Oshrxlimm n, v1::nil => Some (Val.maketotal (Val.shrxl v1 (Vint n))) + | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) + | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) + | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) + + | Onegf, v1::nil => Some (Val.negf v1) + | Oabsf, v1::nil => Some (Val.absf v1) + | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) + | Osubf, v1::v2::nil => Some (Val.subf v1 v2) + | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) + | Odivf, v1::v2::nil => Some (Val.divf v1 v2) + | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2) + | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2) + | Ofmaddf, v1::v2::v3::nil => Some (ExtValues.fmaddf v1 v2 v3) + | Ofmsubf, v1::v2::v3::nil => Some (ExtValues.fmsubf v1 v2 v3) + + | Onegfs, v1::nil => Some (Val.negfs v1) + | Oabsfs, v1::nil => Some (Val.absfs v1) + | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) + | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) + | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) + | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) + | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) + | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) + | Oinvfs, v1::nil => Some (ExtValues.invfs v1) + | Ofmaddfs, v1::v2::v3::nil => Some (ExtValues.fmaddfs v1 v2 v3) + | Ofmsubfs, v1::v2::v3::nil => Some (ExtValues.fmsubfs v1 v2 v3) + + | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) + | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) + | Ointoffloat, v1::nil => Some (Val.maketotal (Val.intoffloat v1)) + | Ointuoffloat, v1::nil => Some (Val.maketotal (Val.intuoffloat v1)) + | Ointofsingle, v1::nil => Some (Val.maketotal (Val.intofsingle v1)) + | Ointuofsingle, v1::nil => Some (Val.maketotal (Val.intuofsingle v1)) + | Osingleofint, v1::nil => Some (Val.maketotal (Val.singleofint v1)) + | Osingleofintu, v1::nil => Some (Val.maketotal (Val.singleofintu v1)) + | Olongoffloat, v1::nil => Some (Val.maketotal (Val.longoffloat v1)) + | Olonguoffloat, v1::nil => Some (Val.maketotal (Val.longuoffloat v1)) + | Ofloatoflong, v1::nil => Some (Val.maketotal (Val.floatoflong v1)) + | Ofloatoflongu, v1::nil => Some (Val.maketotal (Val.floatoflongu v1)) + | Olongofsingle, v1::nil => Some (Val.maketotal (Val.longofsingle v1)) + | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) + | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) + | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) + | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) + | (Oextfz stop start), v0::nil => Some (extfz stop start v0) + | (Oextfs stop start), v0::nil => Some (extfs stop start v0) + | (Oextfzl stop start), v0::nil => Some (extfzl stop start v0) + | (Oextfsl stop start), v0::nil => Some (extfsl stop start v0) + | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) + | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) + | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) + | Oselimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) + | Osellimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) + | _, _ => None + end. + +Definition eval_addressing + (F V: Type) (genv: Genv.t F V) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed2XS scale, v1 :: v2 :: nil => Some (Val.addl v1 (Val.shll v2 (Vint (Int.repr scale)))) + | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2) + | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) + | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) + | Ainstack n, nil => Some (Val.offset_ptr sp n) + | _, _ => None + end. + +Remark eval_addressing_Ainstack: + forall (F V: Type) (genv: Genv.t F V) sp ofs, + eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). +Proof. + intros. reflexivity. +Qed. + +Remark eval_addressing_Ainstack_inv: + forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, + eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. +Proof. + unfold eval_addressing; intros; destruct vl; inv H; auto. +Qed. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; FuncInv + | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => + destruct Archi.ptr64 eqn:?; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | H: (None = Some _) |- _ => + discriminate H + | _ => + idtac + end. + +(** * Static typing of conditions, operators and addressing modes. *) + +Definition type_of_condition (c: condition) : list typ := + match c with + | Ccomp _ => Tint :: Tint :: nil + | Ccompu _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompl _ => Tlong :: Tlong :: nil + | Ccomplu _ => Tlong :: Tlong :: nil + | Ccomplimm _ _ => Tlong :: nil + | Ccompluimm _ _ => Tlong :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Ccompfs _ => Tsingle :: Tsingle :: nil + | Cnotcompfs _ => Tsingle :: Tsingle :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Olongconst _ => (nil, Tlong) + | Ofloatconst f => (nil, Tfloat) + | Osingleconst f => (nil, Tsingle) + | Oaddrsymbol _ _ => (nil, Tptr) + | Oaddrstack _ => (nil, Tptr) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Oaddx _ => (Tint :: Tint :: nil, Tint) + | Oaddximm _ _ => (Tint :: nil, Tint) + | Oneg => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Orevsubimm _ => (Tint :: nil, Tint) + | Orevsubx _ => (Tint :: Tint :: nil, Tint) + | Orevsubximm _ _ => (Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omulimm _ => (Tint :: nil, Tint) + | Omulhs => (Tint :: Tint :: nil, Tint) + | Omulhu => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Omod => (Tint :: Tint :: nil, Tint) + | Omodu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Onand => (Tint :: Tint :: nil, Tint) + | Onandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Onor => (Tint :: Tint :: nil, Tint) + | Onorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Onxor => (Tint :: Tint :: nil, Tint) + | Onxorimm _ => (Tint :: nil, Tint) + | Onot => (Tint :: nil, Tint) + | Oandn => (Tint :: Tint :: nil, Tint) + | Oandnimm _ => (Tint :: nil, Tint) + | Oorn => (Tint :: Tint :: nil, Tint) + | Oornimm _ => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshlimm _ => (Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshrimm _ => (Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshruimm _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Ororimm _ => (Tint :: nil, Tint) + | Omadd => (Tint :: Tint :: Tint :: nil, Tint) + | Omaddimm _ => (Tint :: Tint :: nil, Tint) + | Omsub => (Tint :: Tint :: Tint :: nil, Tint) + + | Omakelong => (Tint :: Tint :: nil, Tlong) + | Olowlong => (Tlong :: nil, Tint) + | Ohighlong => (Tlong :: nil, Tint) + | Ocast32signed => (Tint :: nil, Tlong) + | Ocast32unsigned => (Tint :: nil, Tlong) + | Oaddl => (Tlong :: Tlong :: nil, Tlong) + | Oaddlimm _ => (Tlong :: nil, Tlong) + | Oaddxl _ => (Tlong :: Tlong :: nil, Tlong) + | Oaddxlimm _ _ => (Tlong :: nil, Tlong) + | Orevsublimm _ => (Tlong :: nil, Tlong) + | Orevsubxl _ => (Tlong :: Tlong :: nil, Tlong) + | Orevsubxlimm _ _ => (Tlong :: nil, Tlong) + | Onegl => (Tlong :: nil, Tlong) + | Osubl => (Tlong :: Tlong :: nil, Tlong) + | Omull => (Tlong :: Tlong :: nil, Tlong) + | Omullimm _ => (Tlong :: nil, Tlong) + | Omullhs => (Tlong :: Tlong :: nil, Tlong) + | Omullhu => (Tlong :: Tlong :: nil, Tlong) + | Odivl => (Tlong :: Tlong :: nil, Tlong) + | Odivlu => (Tlong :: Tlong :: nil, Tlong) + | Omodl => (Tlong :: Tlong :: nil, Tlong) + | Omodlu => (Tlong :: Tlong :: nil, Tlong) + | Oandl => (Tlong :: Tlong :: nil, Tlong) + | Oandlimm _ => (Tlong :: nil, Tlong) + | Onandl => (Tlong :: Tlong :: nil, Tlong) + | Onandlimm _ => (Tlong :: nil, Tlong) + | Oorl => (Tlong :: Tlong :: nil, Tlong) + | Oorlimm _ => (Tlong :: nil, Tlong) + | Onorl => (Tlong :: Tlong :: nil, Tlong) + | Onorlimm _ => (Tlong :: nil, Tlong) + | Oxorl => (Tlong :: Tlong :: nil, Tlong) + | Oxorlimm _ => (Tlong :: nil, Tlong) + | Onxorl => (Tlong :: Tlong :: nil, Tlong) + | Onxorlimm _ => (Tlong :: nil, Tlong) + | Onotl => (Tlong :: nil, Tlong) + | Oandnl => (Tlong :: Tlong :: nil, Tlong) + | Oandnlimm _ => (Tlong :: nil, Tlong) + | Oornl => (Tlong :: Tlong :: nil, Tlong) + | Oornlimm _ => (Tlong :: nil, Tlong) + | Oshll => (Tlong :: Tint :: nil, Tlong) + | Oshllimm _ => (Tlong :: nil, Tlong) + | Oshrl => (Tlong :: Tint :: nil, Tlong) + | Oshrlimm _ => (Tlong :: nil, Tlong) + | Oshrlu => (Tlong :: Tint :: nil, Tlong) + | Oshrluimm _ => (Tlong :: nil, Tlong) + | Oshrxlimm _ => (Tlong :: nil, Tlong) + | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) + | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) + | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) + + | Onegf => (Tfloat :: nil, Tfloat) + | Oabsf => (Tfloat :: nil, Tfloat) + | Oaddf + | Osubf + | Omulf + | Odivf + | Ominf + | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) + | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + + | Onegfs => (Tsingle :: nil, Tsingle) + | Oabsfs => (Tsingle :: nil, Tsingle) + | Oaddfs + | Osubfs + | Omulfs + | Odivfs + | Ominfs + | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) + | Oinvfs => (Tsingle :: nil, Tsingle) + | Ofmaddfs | Ofmsubfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle) + + | Osingleoffloat => (Tfloat :: nil, Tsingle) + | Ofloatofsingle => (Tsingle :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ointofsingle => (Tsingle :: nil, Tint) + | Ointuofsingle => (Tsingle :: nil, Tint) + | Osingleofint => (Tint :: nil, Tsingle) + | Osingleofintu => (Tint :: nil, Tsingle) + | Olongoffloat => (Tfloat :: nil, Tlong) + | Olonguoffloat => (Tfloat :: nil, Tlong) + | Ofloatoflong => (Tlong :: nil, Tfloat) + | Ofloatoflongu => (Tlong :: nil, Tfloat) + | Olongofsingle => (Tsingle :: nil, Tlong) + | Olonguofsingle => (Tsingle :: nil, Tlong) + | Osingleoflong => (Tlong :: nil, Tsingle) + | Osingleoflongu => (Tlong :: nil, Tsingle) + | Ocmp c => (type_of_condition c, Tint) + | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) + | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) + | Oinsf _ _ => (Tint :: Tint :: nil, Tint) + | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) + | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) + | Oselimm c ty => (Tint :: arg_type_of_condition0 c :: nil, Tint) + | Osellimm c ty => (Tlong :: arg_type_of_condition0 c :: nil, Tlong) + end. + +(* FIXME: two Tptr ?! *) +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed2XS _ => Tptr :: Tptr :: nil + | Aindexed2 => Tptr :: Tptr :: nil + | Aindexed _ => Tptr :: nil + | Aglobal _ _ => nil + | Ainstack _ => nil + end. + +(** Weak type soundness results for [eval_operation]: + the result values, when defined, are always of the type predicted + by [type_of_operation]. *) + +Section SOUNDNESS. + +Variable A V: Type. +Variable genv: Genv.t A V. + +Remark type_add: + forall v1 v2, Val.has_type (Val.add v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Remark type_addl: + forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. +Qed. + +Remark type_sub: + forall v1 v2, Val.has_type (Val.sub v1 v2) Tint. +Proof. + intros. unfold Val.has_type, Val.sub. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_subl: + forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong. +Proof. + intros. unfold Val.has_type, Val.subl. destruct Archi.ptr64, v1, v2; simpl; auto. + destruct (eq_block _ _); auto. +Qed. + +Remark type_shl: + forall v1 v2, Val.has_type (Val.shl v1 v2) Tint. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + +Remark type_shll: + forall v1 v2, Val.has_type (Val.shll v1 v2) Tlong. +Proof. + destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. +Qed. + +Lemma type_of_operation_sound: + forall op vl sp v m, + op <> Omove -> + eval_operation genv sp op vl m = Some v -> + Val.has_type v (snd (type_of_operation op)). +Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). + intros. + destruct op; simpl; simpl in H0; FuncInv; subst; simpl. + (* move *) + - congruence. + (* intconst, longconst, floatconst, singleconst *) + - exact I. + - exact I. + - exact I. + - exact I. + (* addrsymbol *) + - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... + (* addrstack *) + - destruct sp... + (* castsigned *) + - destruct v0... + - destruct v0... + (* add, addimm *) + - apply type_add. + - apply type_add. + (* addx, addximm *) + - apply type_add. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* neg, sub *) + - destruct v0... + - apply type_sub. + (* revsubimm, revsubx, revsubximm *) + - destruct v0... + - apply type_sub. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* mul, mulimm, mulhs, mulhu *) + - destruct v0; destruct v1... + - destruct v0... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* div, divu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* mod, modu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int.eq i0 Int.zero); inv H2... + (* and, andimm *) + - destruct v0; destruct v1... + - destruct v0... + (* nand, nandimm *) + - destruct v0; destruct v1... + - destruct v0... + (* or, orimm *) + - destruct v0; destruct v1... + - destruct v0... + (* nor, norimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xor, xorimm *) + - destruct v0; destruct v1... + - destruct v0... + (* nxor, nxorimm *) + - destruct v0; destruct v1... + - destruct v0... + (* not *) + - destruct v0... + (* andn, andnimm *) + - destruct v0; destruct v1... + - destruct v0... + (* orn, ornimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shl, shlimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... + - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... + (* shrx *) + - destruct v0; simpl... destruct (Int.ltu n (Int.repr 31)); simpl; trivial. + (* shrimm *) + - destruct v0; simpl... + (* madd *) + - apply type_add. + - apply type_add. + (* msub *) + - apply type_sub. + (* makelong, lowlong, highlong *) + - destruct v0; destruct v1... + - destruct v0... + - destruct v0... + (* cast32 *) + - destruct v0... + - destruct v0... + (* addl, addlimm *) + - apply type_addl. + - apply type_addl. + (* addxl addxlimm *) + - apply type_addl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* negl, subl *) + - destruct v0... + - apply type_subl. + - destruct v0; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - destruct v0... + - apply type_subl. + (* mull, mullhs, mullhu *) + - destruct v0; destruct v1... + - destruct v0... + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* divl, divlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* modl, modlu *) + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... + - destruct v0; destruct v1; simpl in *; inv H0. + destruct (Int64.eq i0 Int64.zero); inv H2... + (* andl, andlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* nandl, nandlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* orl, orlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* norl, norlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* xorl, xorlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* nxorl, nxorlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* notl *) + - destruct v0... + (* andnl, andnlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* ornl, ornlimm *) + - destruct v0; destruct v1... + - destruct v0... + (* shll, shllimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shr, shrimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shru, shruimm *) + - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... + - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... + (* shrxl *) + - destruct v0; simpl... destruct (Int.ltu n (Int.repr 63)); simpl; trivial. + (* maddl, maddlim *) + - apply type_addl. + - apply type_addl. + (* msubl *) + - apply type_subl. + (* negf, absf *) + - destruct v0... + - destruct v0... + (* addf, subf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulf, divf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* minf, maxf *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* fmaddf, fmsubf *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... + (* negfs, absfs *) + - destruct v0... + - destruct v0... + (* addfs, subfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* mulfs, divfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* minfs, maxfs *) + - destruct v0; destruct v1... + - destruct v0; destruct v1... + (* invfs *) + - destruct v0... + (* fmaddfs, fmsubfs *) + - destruct v0; destruct v1; destruct v2... + - destruct v0; destruct v1; destruct v2... + (* singleoffloat, floatofsingle *) + - destruct v0... + - destruct v0... + (* intoffloat, intuoffloat *) + - destruct v0; simpl... destruct (Float.to_int f); simpl; trivial. + - destruct v0; simpl... destruct (Float.to_intu f); simpl; trivial. + (* intofsingle, intuofsingle *) + - destruct v0; simpl... destruct (Float32.to_int f); simpl; trivial. + - destruct v0; simpl... destruct (Float32.to_intu f); simpl; trivial. + (* singleofint, singleofintu *) + - destruct v0; simpl... + - destruct v0; simpl... + (* longoffloat, longuoffloat *) + - destruct v0; simpl... destruct (Float.to_long f); simpl; trivial. + - destruct v0; simpl... destruct (Float.to_longu f); simpl; trivial. + (* floatoflong, floatoflongu *) + - destruct v0; simpl... + - destruct v0; simpl... + (* longofsingle, longuofsingle *) + - destruct v0; simpl... destruct (Float32.to_long f); simpl; trivial. + - destruct v0; simpl... destruct (Float32.to_longu f); simpl; trivial. + (* singleoflong, singleoflongu *) + - destruct v0; simpl... + - destruct v0; simpl... + (* cmp *) + - destruct (eval_condition cond vl m)... destruct b... + (* extfz *) + - unfold extfz. + destruct (is_bitfield _ _). + + destruct v0; simpl; trivial. + + constructor. + (* extfs *) + - unfold extfs. + destruct (is_bitfield _ _). + + destruct v0; simpl; trivial. + + constructor. + (* extfzl *) + - unfold extfzl. + destruct (is_bitfieldl _ _). + + destruct v0; simpl; trivial. + + constructor. + (* extfsl *) + - unfold extfsl. + destruct (is_bitfieldl _ _). + + destruct v0; simpl; trivial. + + constructor. + (* insf *) + - unfold insf, bitfield_mask. + destruct (is_bitfield _ _). + + destruct v0; destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + + constructor. + (* insf *) + - unfold insfl, bitfield_mask. + destruct (is_bitfieldl _ _). + + destruct v0; destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + + constructor. + (* Osel *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. + (* Oselimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. + (* Osellimm *) + - unfold Val.select. destruct (eval_condition0 _ _ m). + + apply Val.normalize_type. + + constructor. +Qed. + +Definition is_trapping_op (op : operation) := + match op with + | Odiv | Odivl | Odivu | Odivlu + | Omod | Omodl | Omodu | Omodlu => true + | _ => false + end. + +Definition args_of_operation op := + if eq_operation op Omove + then 1%nat + else List.length (fst (type_of_operation op)). + +Lemma is_trapping_op_sound: + forall op vl sp m, + is_trapping_op op = false -> + (List.length vl) = args_of_operation op -> + eval_operation genv sp op vl m <> None. +Proof. + unfold args_of_operation. + destruct op; destruct eq_operation; intros; simpl in *; try congruence. + all: try (destruct vl as [ | vh1 vl1]; try discriminate). + all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). + all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). + all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). +Qed. +End SOUNDNESS. + +(** * Manipulating and transforming operations *) + +(** Recognition of move operations. *) + +Definition is_move_operation + (A: Type) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None + end. + +Lemma is_move_operation_correct: + forall (A: Type) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** [negate_condition cond] returns a condition that is logically + equivalent to the negation of [cond]. *) + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompl c => Ccompl(negate_comparison c) + | Ccomplu c => Ccomplu(negate_comparison c) + | Ccomplimm c n => Ccomplimm (negate_comparison c) n + | Ccompluimm c n => Ccompluimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Ccompfs c => Cnotcompfs c + | Cnotcompfs c => Ccompfs c + end. + +Lemma eval_negate_condition: + forall cond vl m, + eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). +Proof. + intros. destruct cond; simpl. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmp_bool. + repeat (destruct vl; auto). apply Val.negate_cmpu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). apply Val.negate_cmpl_bool. + repeat (destruct vl; auto). apply Val.negate_cmplu_bool. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. + repeat (destruct vl; auto). + repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. +Qed. + +(** Shifting stack-relative references. This is used in [Stacking]. *) + +Definition shift_stack_addressing (delta: Z) (addr: addressing) := + match addr with + | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => addr + end. + +Definition shift_stack_operation (delta: Z) (op: operation) := + match op with + | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) + | _ => op + end. + +Lemma type_shift_stack_addressing: + forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. +Proof. + intros. destruct addr; auto. +Qed. + +Lemma type_shift_stack_operation: + forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. +Proof. + intros. destruct op; auto. +Qed. + +Lemma eval_shift_stack_addressing: + forall F V (ge: Genv.t F V) sp addr vl delta, + eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = + eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. +Proof. + intros. destruct addr; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +Lemma eval_shift_stack_operation: + forall F V (ge: Genv.t F V) sp op vl m delta, + eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = + eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. +Proof. + intros. destruct op; simpl; auto. destruct vl; auto. + rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. +Qed. + +(** Offset an addressing mode [addr] by a quantity [delta], so that + it designates the pointer [delta] bytes past the pointer designated + by [addr]. May be undefined, in which case [None] is returned. *) + +Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := + match addr with + | Aindexed2 | Aindexed2XS _ => None + | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) + | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) + | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) + end. + +Lemma eval_offset_addressing: + forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, + offset_addressing addr delta = Some addr' -> + eval_addressing ge sp addr args = Some v -> + Archi.ptr64 = false -> + eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). +Proof. + intros. + assert (A: forall x n, + Val.offset_ptr x (Ptrofs.add n (Ptrofs.repr delta)) = + Val.add (Val.offset_ptr x n) (Vint (Int.repr delta))). + { intros; destruct x; simpl; auto. rewrite H1. + rewrite Ptrofs.add_assoc. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. } + destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. +- rewrite A; auto. +- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. + simpl. rewrite H1. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. +- rewrite A; auto. +Qed. + +(** Operations that are so cheap to recompute that CSE should not factor them out. *) + +Definition is_trivial_op (op: operation) : bool := + match op with + | Omove => true + | Ointconst n => Int.eq (Int.sign_ext 12 n) n + | Olongconst n => Int64.eq (Int64.sign_ext 12 n) n + | Oaddrstack _ => true + | _ => false + end. + +(** Operations that depend on the memory state. *) + +Definition op_depends_on_memory (op: operation) : bool := + match op with + | Ocmp (Ccompu _) => negb Archi.ptr64 + | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 + | Ocmp (Ccomplu _) => Archi.ptr64 + | Ocmp (Ccompluimm _ _) => Archi.ptr64 + + | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64 + | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64 + + | _ => false + end. + +Lemma op_depends_on_memory_correct: + forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, + op_depends_on_memory op = false -> + eval_operation ge sp op args m1 = eval_operation ge sp op args m2. +Proof. + intros until m2. destruct op; simpl; try congruence. + - destruct cond; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. + - destruct c0; simpl; try congruence; + intros SF; auto; rewrite ? negb_false_iff in SF; + unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. +Qed. + +(** Global variables mentioned in an operation or addressing mode *) + +Definition globals_addressing (addr: addressing) : list ident := + match addr with + | Aglobal s ofs => s :: nil + | _ => nil + end. + +Definition globals_operation (op: operation) : list ident := + match op with + | Oaddrsymbol s ofs => s :: nil + | _ => nil + end. + +(** * Invariance and compatibility properties. *) + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Hypothesis agree_on_symbols: + forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing; destruct addr; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +Lemma eval_operation_preserved: + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. +Proof. + intros. + unfold eval_operation; destruct op; auto. destruct vl; auto. + unfold Genv.symbol_address. rewrite agree_on_symbols; auto. +Qed. + +End GENV_TRANSF. + +(** Compatibility of the evaluation functions with value injections. *) + +Section EVAL_COMPAT. + +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. +Variable f: meminj. + +Variable m1: mem. +Variable m2: mem. + +Hypothesis valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_inj: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. + +Hypothesis weak_valid_pointer_no_overflow: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. + +Hypothesis valid_different_pointers_inj: + forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). + +Ltac InvInject := + match goal with + | [ H: Val.inject _ (Vint _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vfloat _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ nil _ |- _ ] => + inv H; InvInject + | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => + inv H; InvInject + | _ => idtac + end. + +Lemma eval_condition_inj: + forall cond vl1 vl2 b, + Val.inject_list f vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; simpl in H0; inv H0; auto. +- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +- inv H3; inv H2; simpl in H0; inv H0; auto. +Qed. + +Lemma eval_condition0_inj: + forall cond v1 v2 b, + Val.inject f v1 v2 -> + eval_condition0 cond v1 m1 = Some b -> + eval_condition0 cond v2 m2 = Some b. +Proof. + intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. + - inv H; simpl in *; congruence. + - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. + - inv H; simpl in *; congruence. + - eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => + exists v1; split; auto + | _ => idtac + end. + +Lemma eval_operation_inj: + forall op sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_operation op) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_operation ge1 sp1 op vl1 m1 = Some v1 -> + exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. + (* addrsymbol *) + - apply GL; simpl; auto. + (* addrstack *) + - apply Val.offset_ptr_inject; auto. + (* castsigned *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* add, addimm *) + - apply Val.add_inject; auto. + - apply Val.add_inject; auto. + (* addx, addximm *) + - apply Val.add_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* neg, sub *) + - inv H4; simpl; auto. + - apply Val.sub_inject; auto. + (* revsubimm, revsubx, revsubximm *) + - inv H4; simpl; trivial. + - apply Val.sub_inject; trivial. + inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. + - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. + (* mul, mulimm, mulhs, mulhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* div, divu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* mod, modu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero + || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. + (* and, andimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* nand, nandimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* or, orimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* nor, norimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xor, xorimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* nxor, nxorimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* not *) + - inv H4; simpl; auto. + (* andn, andnimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* orn, ornimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shl, shlimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shru, shruimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. + (* shrx *) + - inv H4; simpl; auto. + destruct (Int.ltu n (Int.repr 31)); inv H; simpl; auto. + (* rorimm *) + - inv H4; simpl; auto. + (* madd, maddim *) + - inv H2; inv H3; inv H4; simpl; auto. + - inv H2; inv H4; simpl; auto. + (* msub *) + - apply Val.sub_inject; auto. + inv H3; inv H2; simpl; auto. + (* makelong, highlong, lowlong *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* cast32 *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addl, addlimm *) + - apply Val.addl_inject; auto. + - apply Val.addl_inject; auto. + (* addxl, addxlimm *) + - apply Val.addl_inject; auto. + inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + (* negl, subl *) + - inv H4; simpl; auto. + - apply Val.subl_inject; auto. + inv H4; inv H2; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; trivial; + destruct (Int.ltu _ _); simpl; trivial. + - inv H4; simpl; auto. + - apply Val.subl_inject; auto. + (* mull, mullhs, mullhu *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* divl, divlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* modl, modlu *) + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero + || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. + TrivialExists. + - inv H4; inv H3; simpl in H1; inv H1. simpl. + destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. + (* andl, andlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* nandl, nandlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* orl, orlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* norl, norlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* xorl, xorlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* nxorl, nxorlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* notl *) + - inv H4; simpl; auto. + (* andnl, andnlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* ornl, ornlimm *) + - inv H4; inv H2; simpl; auto. + - inv H4; simpl; auto. + (* shll, shllimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shr, shrimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shru, shruimm *) + - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. + - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. + (* shrx *) + - inv H4; simpl; auto. + destruct (Int.ltu n (Int.repr 63)); simpl; auto. + + (* maddl, maddlimm *) + - apply Val.addl_inject; auto. + inv H2; inv H3; inv H4; simpl; auto. + - apply Val.addl_inject; auto. + inv H4; inv H2; simpl; auto. + (* msubl, msublimm *) + - apply Val.subl_inject; auto. + inv H2; inv H3; inv H4; simpl; auto. + + (* negf, absf *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addf, subf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulf, divf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* minf, maxf *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* fmaddf, fmsubf *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. + (* negfs, absfs *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* addfs, subfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* mulfs, divfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* minfs, maxfs *) + - inv H4; inv H2; simpl; auto. + - inv H4; inv H2; simpl; auto. + (* invfs *) + - inv H4; simpl; auto. + (* fmaddfs, fmsubfs *) + - inv H4; inv H3; inv H2; simpl; auto. + - inv H4; inv H3; inv H2; simpl; auto. + (* singleoffloat, floatofsingle *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* intoffloat, intuoffloat *) + - inv H4; simpl; auto. destruct (Float.to_int f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float.to_intu f0); simpl; auto. + (* intofsingle, intuofsingle *) + - inv H4; simpl; auto. destruct (Float32.to_int f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float32.to_intu f0); simpl; auto. + (* singleofint, singleofintu *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* longoffloat, longuoffloat *) + - inv H4; simpl; auto. destruct (Float.to_long f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float.to_longu f0); simpl; auto. + (* floatoflong, floatoflongu *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* longofsingle, longuofsingle *) + - inv H4; simpl; auto. destruct (Float32.to_long f0); simpl; auto. + - inv H4; simpl; auto. destruct (Float32.to_longu f0); simpl; auto. + (* singleoflong, singleoflongu *) + - inv H4; simpl; auto. + - inv H4; simpl; auto. + (* cmp *) + - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. + exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. + destruct b; simpl; constructor. + simpl; constructor. + + (* extfz *) + - unfold extfz. + destruct (is_bitfield _ _). + + inv H4; trivial. + + trivial. + + (* extfs *) + - unfold extfs. + destruct (is_bitfield _ _). + + inv H4; trivial. + + trivial. + + (* extfzl *) + - unfold extfzl. + destruct (is_bitfieldl _ _). + + inv H4; trivial. + + trivial. + + (* extfsl *) + - unfold extfsl. + destruct (is_bitfieldl _ _). + + inv H4; trivial. + + trivial. + + (* insf *) + - unfold insf. + destruct (is_bitfield _ _). + + inv H4; inv H2; trivial. + simpl. destruct (Int.ltu _ _); trivial. + simpl. trivial. + + trivial. + + (* insfl *) + - unfold insfl. + destruct (is_bitfieldl _ _). + + inv H4; inv H2; trivial. + simpl. destruct (Int.ltu _ _); trivial. + simpl. trivial. + + trivial. + + (* Osel *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 c0 v2 m1) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Oselimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 _ _ _) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. + + (* Osellimm *) + - apply Val.select_inject; trivial. + destruct (eval_condition0 _ _ _) eqn:Hcond. + + right. + symmetry. + eapply eval_condition0_inj; eassumption. + + left. trivial. +Qed. + +Lemma eval_addressing_inj: + forall addr sp1 vl1 sp2 vl2 v1, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = Some v1 -> + exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. +Proof. + intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. + - apply Val.addl_inject; trivial. + destruct v0; destruct v'0; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial; inv H3. + apply Val.inject_long. + - apply Val.addl_inject; auto. + - apply Val.offset_ptr_inject; auto. + - apply H; simpl; auto. + - apply Val.offset_ptr_inject; auto. +Qed. + +Lemma eval_addressing_inj_none: + forall addr sp1 vl1 sp2 vl2, + (forall id ofs, + In id (globals_addressing addr) -> + Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> + Val.inject f sp1 sp2 -> + Val.inject_list f vl1 vl2 -> + eval_addressing ge1 sp1 addr vl1 = None -> + eval_addressing ge2 sp2 addr vl2 = None. +Proof. + intros until vl2. intros Hglobal Hinjsp Hinjvl. + destruct addr; simpl in *. + 1,2: inv Hinjvl; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + 2,3: inv Hinjvl; trivial; discriminate. + inv Hinjvl; trivial; inv H0; trivial; + inv H; trivial; discriminate. +Qed. + +End EVAL_COMPAT. + +(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) + +Section EVAL_LESSDEF. + +Variable F V: Type. +Variable genv: Genv.t F V. + +Remark valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_extends: + forall m1 m2, Mem.extends m1 m2 -> + forall b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. +Proof. + intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. +Qed. + +Remark weak_valid_pointer_no_overflow_extends: + forall m1 b1 ofs b2 delta, + Some(b1, 0) = Some(b2, delta) -> + Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> + 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. +Proof. + intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. +Qed. + +Remark valid_different_pointers_extends: + forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + b1 <> b2 -> + Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> + Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> + Some(b1, 0) = Some (b1', delta1) -> + Some(b2, 0) = Some (b2', delta2) -> + b1' <> b2' \/ + Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). +Proof. + intros. inv H2; inv H3. auto. +Qed. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + rewrite <- val_inject_list_lessdef. eauto. auto. +Qed. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1 m1 m2, + Val.lessdef_list vl1 vl2 -> + Mem.extends m1 m2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_operation genv sp op vl2 m2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_operation_inj with (m1 := m1) (sp1 := sp). + apply valid_pointer_extends; auto. + apply weak_valid_pointer_extends; auto. + apply weak_valid_pointer_no_overflow_extends. + apply valid_different_pointers_extends; auto. + intros. apply val_inject_lessdef. auto. + apply val_inject_lessdef; auto. + eauto. + auto. + destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. rewrite val_inject_list_lessdef in H. + assert (exists v2 : val, + eval_addressing genv sp addr vl2 = Some v2 + /\ Val.inject (fun b => Some(b, 0)) v1 v2). + eapply eval_addressing_inj with (sp1 := sp). + intros. rewrite <- val_inject_lessdef; auto. + rewrite <- val_inject_lessdef; auto. + eauto. auto. + destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. +Qed. + + +Lemma eval_addressing_lessdef_none: + forall sp addr vl1 vl2, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = None -> + eval_addressing genv sp addr vl2 = None. +Proof. + intros until vl2. intros Hlessdef Heval1. + destruct addr; simpl in *. + 1, 2, 4, 5: inv Hlessdef; trivial; + inv H0; trivial; + inv H2; trivial; + discriminate. + inv Hlessdef; trivial. + inv H0; trivial. + discriminate. +Qed. + +End EVAL_LESSDEF. + +(** Compatibility of the evaluation functions with memory injections. *) + +Section EVAL_INJECT. + +Variable F V: Type. +Variable genv: Genv.t F V. +Variable f: meminj. +Hypothesis globals: meminj_preserves_globals genv f. +Variable sp1: block. +Variable sp2: block. +Variable delta: Z. +Hypothesis sp_inj: f sp1 = Some(sp2, delta). + +Remark symbol_address_inject: + forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. + exploit (proj1 globals); eauto. intros. + econstructor; eauto. rewrite Ptrofs.add_zero; auto. +Qed. + +Lemma eval_condition_inject: + forall cond vl1 vl2 b m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. +Qed. + +Lemma eval_addressing_inject: + forall addr vl1 vl2 v1, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> + exists v2, + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_addressing_inject_none: + forall addr vl1 vl2, + Val.inject_list f vl1 vl2 -> + eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> + eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. +Proof. + intros. + rewrite eval_shift_stack_addressing. + eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +Lemma eval_operation_inject: + forall op vl1 vl2 v1 m1 m2, + Val.inject_list f vl1 vl2 -> + Mem.inject f m1 m2 -> + eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> + exists v2, + eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 + /\ Val.inject f v1 v2. +Proof. + intros. + rewrite eval_shift_stack_operation. simpl. + eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. + intros; eapply Mem.valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_val; eauto. + intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. + intros; eapply Mem.different_pointers_inject; eauto. + intros. apply symbol_address_inject. + econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. +Qed. + +End EVAL_INJECT. + +(** * Handling of builtin arguments *) + +Definition builtin_arg_ok_1 + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match c, ba with + | OK_all, _ => true + | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true + | OK_addrstack, BA_addrstack _ => true + | OK_addressing, BA_addrstack _ => true + | OK_addressing, BA_addptr (BA _) (BA_int _) => true + | OK_addressing, BA_addptr (BA _) (BA_long _) => true + | _, _ => false + end. + +Definition builtin_arg_ok + (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := + match ba with + | (BA _ | BA_splitlong (BA _) (BA _)) => true + | _ => builtin_arg_ok_1 ba c + end. diff --git a/kvx/Peephole.v b/kvx/Peephole.v new file mode 100644 index 00000000..35f4bbd9 --- /dev/null +++ b/kvx/Peephole.v @@ -0,0 +1,158 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import Asmvliw. +Require Import Values. +Require Import Integers. +Require Import AST. +Require Compopts. + +Definition gpreg_q_list : list gpreg_q := +R0R1 :: R2R3 :: R4R5 :: R6R7 :: R8R9 +:: R10R11 :: R12R13 :: R14R15 :: R16R17 :: R18R19 +:: R20R21 :: R22R23 :: R24R25 :: R26R27 :: R28R29 +:: R30R31 :: R32R33 :: R34R35 :: R36R37 :: R38R39 +:: R40R41 :: R42R43 :: R44R45 :: R46R47 :: R48R49 +:: R50R51 :: R52R53 :: R54R55 :: R56R57 :: R58R59 +:: R60R61 :: R62R63 :: nil. + +Definition gpreg_o_list : list gpreg_o := +R0R1R2R3 :: R4R5R6R7 :: R8R9R10R11 :: R12R13R14R15 +:: R16R17R18R19 :: R20R21R22R23 :: R24R25R26R27 :: R28R29R30R31 +:: R32R33R34R35 :: R36R37R38R39 :: R40R41R42R43 :: R44R45R46R47 +:: R48R49R50R51 :: R52R53R54R55 :: R56R57R58R59 :: R60R61R62R63 :: nil. + +Fixpoint gpreg_q_search_rec r0 r1 l := + match l with + | h :: t => + let (s0, s1) := gpreg_q_expand h in + if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) + then Some h + else gpreg_q_search_rec r0 r1 t + | nil => None + end. + +Fixpoint gpreg_o_search_rec r0 r1 r2 r3 l := + match l with + | h :: t => + match gpreg_o_expand h with + | (((s0, s1), s2), s3) => + if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) && + (gpreg_eq r2 s2) && (gpreg_eq r3 s3) + then Some h + else gpreg_o_search_rec r0 r1 r2 r3 t + end + | nil => None + end. + +Definition gpreg_q_search (r0 : gpreg) (r1 : gpreg) : option gpreg_q := + gpreg_q_search_rec r0 r1 gpreg_q_list. + +Definition gpreg_o_search r0 r1 r2 r3 : option gpreg_o := + gpreg_o_search_rec r0 r1 r2 r3 gpreg_o_list. + +Parameter print_found_store: forall A, Z -> A -> A. + +Definition coalesce_octuples := true. + +Fixpoint coalesce_mem (insns : list basic) : list basic := + match insns with + | nil => nil + | h0 :: t0 => + match t0 with + | h1 :: t1 => + match h0, h1 with + | (PStoreRRO Psd_a rs0 ra0 ofs0), + (PStoreRRO Psd_a rs1 ra1 ofs1) => + match gpreg_q_search rs0 rs1 with + | Some rs0rs1 => + let zofs0 := Ptrofs.signed ofs0 in + let zofs1 := Ptrofs.signed ofs1 in + if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) + then + if coalesce_octuples + then + match t1 with + | (PStoreRRO Psd_a rs2 ra2 ofs2) :: + (PStoreRRO Psd_a rs3 ra3 ofs3) :: t3 => + match gpreg_o_search rs0 rs1 rs2 rs3 with + | Some octuple => + let zofs2 := Ptrofs.signed ofs2 in + let zofs3 := Ptrofs.signed ofs3 in + if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && + (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) + then (PStore (PStoreORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) + else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + | None => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + | _ => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + else h0 :: (coalesce_mem t0) + | None => h0 :: (coalesce_mem t0) + end + + | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)), + (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) => + match gpreg_q_search rd0 rd1 with + | Some rd0rd1 => + let zofs0 := Ptrofs.signed ofs0 in + let zofs1 := Ptrofs.signed ofs1 in + if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) && negb (ireg_eq ra0 rd0) + then + if coalesce_octuples + then + match t1 with + | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) :: + (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 => + match gpreg_o_search rd0 rd1 rd2 rd3 with + | Some octuple => + let zofs2 := Ptrofs.signed ofs2 in + let zofs3 := Ptrofs.signed ofs3 in + if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && + (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) && + negb (ireg_eq ra0 rd1) && negb (ireg_eq ra0 rd2) + then (PLoad (PLoadORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) + else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + | None => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + | _ => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + end + else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) + else h0 :: (coalesce_mem t0) + | None => h0 :: (coalesce_mem t0) + end + | _, _ => h0 :: (coalesce_mem t0) + end + | nil => h0 :: nil + end + end. + +Definition optimize_body (insns : list basic) := + if Compopts.optim_coalesce_mem tt + then coalesce_mem insns + else insns. + +Program Definition optimize_bblock (bb : bblock) := + let optimized := optimize_body (body bb) in + let wf_ok := wf_bblockb optimized (exit bb) in + {| header := header bb; + body := if wf_ok then optimized else (body bb); + exit := exit bb |}. +Next Obligation. + destruct (wf_bblockb (optimize_body (body bb))) eqn:Rwf. + - rewrite Rwf. simpl. trivial. + - exact (correct bb). +Qed. diff --git a/kvx/PostpassScheduling.v b/kvx/PostpassScheduling.v new file mode 100644 index 00000000..7518866d --- /dev/null +++ b/kvx/PostpassScheduling.v @@ -0,0 +1,530 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Errors AST Integers. +Require Import Asmblock Axioms Memory Globalenvs. +Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops. +Require Peephole. + +Local Open Scope error_monad_scope. + +(** Oracle taking as input a basic block, + returns a schedule expressed as a list of bundles *) +Axiom schedule: bblock -> (list (list basic)) * option control. + +Extract Constant schedule => "PostpassSchedulingOracle.schedule". + +Definition state' := L.mem. +Definition outcome' := option state'. + +Definition bblock' := L.bblock. + +Definition exec' := L.run. + +Definition exec := exec_bblock. + +(* Lemmas necessary for defining concat_all *) +Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. +Proof. + intros. destruct l; simpl. + - contradiction. + - discriminate. +Qed. + +Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. +Proof. + destruct l. + - intros. simpl; auto. + - intros. rewrite <- app_comm_cons. discriminate. +Qed. + + + +Definition check_size bb := + if zlt Ptrofs.max_unsigned (size bb) + then Error (msg "PostpassSchedulingproof.check_size") + else OK tt. + +Program Definition concat2 (bb bb': bblock) : res bblock := + do ch <- check_size bb; + do ch' <- check_size bb'; + match (exit bb) with + | None => + match (header bb') with + | nil => + match (exit bb') with + | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") + | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end + | _ => Error (msg "PostpassSchedulingproof.concat2") + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. + apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. + inversion_clear WF'. inversion_clear WF. clear H1 H3. + inversion H2; inversion H0. + + left. apply app_nonil. auto. + + right. auto. + + left. apply app_nonil2. auto. + + right. auto. + - unfold builtin_alone. intros. rewrite H0 in H. + assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). + apply (H ef args res). contradict H1. auto. +Defined. + +Lemma concat2_zlt_size: + forall a b bb, + concat2 a b = OK bb -> + size a <= Ptrofs.max_unsigned + /\ size b <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. + split. + - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. + - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. +Qed. + +Lemma concat2_noexit: + forall a b bb, + concat2 a b = OK bb -> + exit a = None. +Proof. + intros. destruct a as [hd bdy ex WF]; simpl in *. + destruct ex as [e|]; simpl in *; auto. + unfold concat2 in H. simpl in H. monadInv H. +Qed. + +Lemma concat2_decomp: + forall a b bb, + concat2 a b = OK bb -> + body bb = body a ++ body b + /\ exit bb = exit b. +Proof. + intros. exploit concat2_noexit; eauto. intros. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. + subst exa. + unfold concat2 in H; simpl in H. + destruct hdb. + - destruct exb. + + destruct c. + * destruct i; monadInv H; split; auto. + * monadInv H. split; auto. + + monadInv H. split; auto. + - monadInv H. +Qed. + +Lemma concat2_size: + forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. +Proof. + intros. unfold concat2 in H. + destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. + destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). + - destruct c. + + destruct i; monadInv EQ2; + unfold size; simpl; rewrite app_length; rewrite Nat.add_0_r; rewrite <- Nat2Z.inj_add; rewrite Nat.add_assoc; reflexivity. + + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. + - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. +Qed. + +Lemma concat2_header: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> header bb = header tbb. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. + - destruct c. + + destruct i; try discriminate; congruence. + + congruence. + - congruence. +Qed. + +Lemma concat2_no_header_in_middle: + forall bb bb' tbb, + concat2 bb bb' = OK tbb -> + header bb' = nil. +Proof. + intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. + unfold concat2 in H. simpl in H. monadInv H. + destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. +Qed. + + + +Fixpoint concat_all (lbb: list bblock) : res bblock := + match lbb with + | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") + | bb::nil => OK bb + | bb::lbb => + do bb' <- concat_all lbb; + concat2 bb bb' + end. + +Lemma concat_all_size : + forall lbb a bb bb', + concat_all (a :: lbb) = OK bb -> + concat_all lbb = OK bb' -> + size bb = size a + size bb'. +Proof. + intros. unfold concat_all in H. fold concat_all in H. + destruct lbb; try discriminate. + monadInv H. rewrite H0 in EQ. inv EQ. + apply concat2_size. assumption. +Qed. + +Lemma concat_all_header: + forall lbb bb tbb, + concat_all (bb::lbb) = OK tbb -> header bb = header tbb. +Proof. + destruct lbb. + - intros. simpl in H. congruence. + - intros. simpl in H. destruct lbb. + + inv H. eapply concat2_header; eassumption. + + monadInv H. eapply concat2_header; eassumption. +Qed. + +Lemma concat_all_no_header_in_middle: + forall lbb tbb, + concat_all lbb = OK tbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + induction lbb; intros; try constructor. + simpl. simpl in H. destruct lbb. + - constructor. + - monadInv H. simpl tl in IHlbb. constructor. + + apply concat2_no_header_in_middle in EQ0. apply concat_all_header in EQ. congruence. + + apply IHlbb in EQ. assumption. +Qed. + +Inductive is_concat : bblock -> list bblock -> Prop := + | mk_is_concat: forall tbb lbb, concat_all lbb = OK tbb -> is_concat tbb lbb. + +Definition verify_schedule (bb bb' : bblock) : res unit := + match bblock_simub bb bb' with + | true => OK tt + | false => Error (msg "PostpassScheduling.verify_schedule") + end. + + +Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). + +Lemma verify_size_size: + forall bb lbb, verify_size bb lbb = OK tt -> size bb = size_blocks lbb. +Proof. + intros. unfold verify_size in H. destruct (size bb =? size_blocks lbb) eqn:SIZE; try discriminate. + apply Z.eqb_eq. assumption. +Qed. + +Lemma verify_schedule_no_header: + forall bb bb', + verify_schedule (no_header bb) bb' = verify_schedule bb bb'. +Proof. + intros. unfold verify_schedule. unfold bblock_simub. unfold pure_bblock_simu_test, bblock_simu_test. rewrite trans_block_noheader_inv. + reflexivity. +Qed. + + +Lemma stick_header_verify_schedule: + forall hd bb' hbb' bb, + stick_header hd bb' = hbb' -> + verify_schedule bb bb' = verify_schedule bb hbb'. +Proof. + intros. unfold verify_schedule. unfold bblock_simub, pure_bblock_simu_test, bblock_simu_test. + rewrite <- H. rewrite trans_block_header_inv. reflexivity. +Qed. + +Lemma check_size_stick_header: + forall bb hd, + check_size bb = check_size (stick_header hd bb). +Proof. + intros. unfold check_size. rewrite stick_header_size. reflexivity. +Qed. + +Lemma stick_header_concat2: + forall bb bb' hd tbb, + concat2 bb bb' = OK tbb -> + concat2 (stick_header hd bb) bb' = OK (stick_header hd tbb). +Proof. + intros. monadInv H. erewrite check_size_stick_header in EQ. + unfold concat2. rewrite EQ. rewrite EQ1. simpl. + destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. + destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. + - destruct c. + + destruct i; try discriminate; inv EQ2; unfold stick_header; simpl; reflexivity. + + inv EQ2. unfold stick_header; simpl. reflexivity. + - inv EQ2. unfold stick_header; simpl. reflexivity. +Qed. + +Lemma stick_header_concat_all: + forall bb c tbb hd, + concat_all (bb :: c) = OK tbb -> + concat_all (stick_header hd bb :: c) = OK (stick_header hd tbb). +Proof. + intros. simpl in *. destruct c; try congruence. + monadInv H. rewrite EQ. simpl. + apply stick_header_concat2. assumption. +Qed. + + + +Definition stick_header_code (h : list label) (lbb : list bblock) := + match (head lbb) with + | None => Error (msg "PostpassScheduling.stick_header: empty schedule") + | Some fst => OK ((stick_header h fst) :: tail lbb) + end. + +Lemma stick_header_code_no_header: + forall bb c, + stick_header_code (header bb) (no_header bb :: c) = OK (bb :: c). +Proof. + intros. unfold stick_header_code. simpl. rewrite stick_header_no_header. reflexivity. +Qed. + +Lemma hd_tl_size: + forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). +Proof. + destruct lbb. + - intros. simpl in H. discriminate. + - intros. simpl in H. inv H. simpl. reflexivity. +Qed. + +Lemma stick_header_code_size: + forall h lbb lbb', stick_header_code h lbb = OK lbb' -> size_blocks lbb = size_blocks lbb'. +Proof. + intros. unfold stick_header_code in H. destruct (hd_error lbb) eqn:HD; try discriminate. + inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. +Qed. + +Lemma stick_header_code_no_header_in_middle: + forall c h lbb, + stick_header_code h c = OK lbb -> + Forall (fun b => header b = nil) (tl c) -> + Forall (fun b => header b = nil) (tl lbb). +Proof. + destruct c; intros. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. simpl in H0. + simpl. assumption. +Qed. + +Lemma stick_header_code_concat_all: + forall hd lbb hlbb tbb, + stick_header_code hd lbb = OK hlbb -> + concat_all lbb = OK tbb -> + exists htbb, + concat_all hlbb = OK htbb + /\ stick_header hd tbb = htbb. +Proof. + intros. exists (stick_header hd tbb). split; auto. + destruct lbb. + - unfold stick_header_code in H. simpl in H. discriminate. + - unfold stick_header_code in H. simpl in H. inv H. + apply stick_header_concat_all. assumption. +Qed. + +Program Definition make_bblock_from_basics lb := + match lb with + | nil => Error (msg "PostpassScheduling.make_bblock_from_basics") + | b :: lb => OK {| header := nil; body := b::lb; exit := None |} + end. + +Fixpoint schedule_to_bblocks_nocontrol llb := + match llb with + | nil => OK nil + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_nocontrol llb; + OK (bb :: lbb) + end. + +Program Definition make_bblock_from_basics_and_control lb c := + match c with + | PExpand (Pbuiltin _ _ _) => Error (msg "PostpassScheduling.make_bblock_from_basics_and_control") + | PCtlFlow cf => OK {| header := nil; body := lb; exit := Some (PCtlFlow cf) |} + end. +Next Obligation. + apply wf_bblock_refl. constructor. + - right. discriminate. + - discriminate. +Qed. + +Fixpoint schedule_to_bblocks_wcontrol llb c := + match llb with + | nil => OK ((bblock_single_inst (PControl c)) :: nil) + | lb :: nil => do bb <- make_bblock_from_basics_and_control lb c; OK (bb :: nil) + | lb :: llb => do bb <- make_bblock_from_basics lb; + do lbb <- schedule_to_bblocks_wcontrol llb c; + OK (bb :: lbb) + end. + +Definition schedule_to_bblocks (llb: list (list basic)) (oc: option control) : res (list bblock) := + match oc with + | None => schedule_to_bblocks_nocontrol llb + | Some c => schedule_to_bblocks_wcontrol llb c + end. + +Definition do_schedule (bb: bblock) : res (list bblock) := + if (Z.eqb (size bb) 1) then OK (bb::nil) + else match (schedule bb) with (llb, oc) => schedule_to_bblocks llb oc end. + +Definition verify_par_bblock (bb: bblock) : res unit := + if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock"). + +Fixpoint verify_par (lbb: list bblock) := + match lbb with + | nil => OK tt + | bb :: lbb => do res <- verify_par_bblock bb; verify_par lbb + end. + +Definition verified_schedule_nob (bb : bblock) : res (list bblock) := + let bb' := no_header bb in + let bb'' := Peephole.optimize_bblock bb' in + do lbb <- do_schedule bb''; + do tbb <- concat_all lbb; + do sizecheck <- verify_size bb lbb; + do schedcheck <- verify_schedule bb' tbb; + do res <- stick_header_code (header bb) lbb; + do parcheck <- verify_par res; + OK res. + +Lemma verified_schedule_nob_size: + forall bb lbb, verified_schedule_nob bb = OK lbb -> size bb = size_blocks lbb. +Proof. + intros. monadInv H. erewrite <- stick_header_code_size; eauto. + apply verify_size_size. + destruct x1; try discriminate. assumption. +Qed. + +Lemma verified_schedule_nob_no_header_in_middle: + forall lbb bb, + verified_schedule_nob bb = OK lbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. + eapply concat_all_no_header_in_middle. eassumption. +Qed. + +Lemma verified_schedule_nob_header: + forall bb tbb lbb, + verified_schedule_nob bb = OK (tbb :: lbb) -> + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. +Proof. + intros. split. + - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. + simpl. reflexivity. + - apply verified_schedule_nob_no_header_in_middle in H. assumption. +Qed. + + +Definition verified_schedule (bb : bblock) : res (list bblock) := + match exit bb with + | Some (PExpand (Pbuiltin ef args res)) => OK (bb::nil) (* Special case for ensuring the lemma verified_schedule_builtin_idem *) + | _ => verified_schedule_nob bb + end. + +Lemma verified_schedule_size: + forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. + all: try (apply verified_schedule_nob_size; auto; fail). + inv H. simpl. omega. +Qed. + +Lemma verified_schedule_no_header_in_middle: + forall lbb bb, + verified_schedule bb = OK lbb -> + Forall (fun b => header b = nil) (tail lbb). +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. + all: try (eapply verified_schedule_nob_no_header_in_middle; eauto; fail). + inv H. simpl. auto. +Qed. + +Lemma verified_schedule_header: + forall bb tbb lbb, + verified_schedule bb = OK (tbb :: lbb) -> + header bb = header tbb + /\ Forall (fun b => header b = nil) lbb. +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. + all: try (eapply verified_schedule_nob_header; eauto; fail). + inv H. split; simpl; auto. +Qed. + + +Lemma verified_schedule_nob_correct: + forall ge f bb lbb, + verified_schedule_nob bb = OK lbb -> + exists tbb, + is_concat tbb lbb + /\ bblock_simu ge f bb tbb. +Proof. + intros. monadInv H. + exploit stick_header_code_concat_all; eauto. + intros (tbb & CONC & STH). + exists tbb. split; auto. constructor; auto. + rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto. + eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2. + destruct (bblock_simub _ _); auto; try discriminate. +Qed. + +Theorem verified_schedule_correct: + forall ge f bb lbb, + verified_schedule bb = OK lbb -> + exists tbb, + is_concat tbb lbb + /\ bblock_simu ge f bb tbb. +Proof. + intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. + all: try (eapply verified_schedule_nob_correct; eauto; fail). + inv H. eexists. split; simpl; auto. constructor; auto. simpl; auto. constructor; auto. +Qed. + +Lemma verified_schedule_builtin_idem: + forall bb ef args res lbb, + exit bb = Some (PExpand (Pbuiltin ef args res)) -> + verified_schedule bb = OK lbb -> + lbb = bb :: nil. +Proof. + intros. unfold verified_schedule in H0. rewrite H in H0. inv H0. reflexivity. +Qed. + + +Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := + match lbb with + | nil => OK nil + | (cons bb lbb) => + do tlbb <- transf_blocks lbb; + do tbb <- verified_schedule bb; + OK (tbb ++ tlbb) + end. + +Definition transl_function (f: function) : res function := + do lb <- transf_blocks (fn_blocks f); + OK (mkfunction (fn_sig f) lb). + +Definition transf_function (f: function) : res function := + do tf <- transl_function f; + if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) + then Error (msg "code size exceeded") + else OK tf. + +Definition transf_fundef (f: fundef) : res fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: program) : res program := + transform_partial_program transf_fundef p. diff --git a/kvx/PostpassSchedulingOracle.ml b/kvx/PostpassSchedulingOracle.ml new file mode 100644 index 00000000..822c0dc0 --- /dev/null +++ b/kvx/PostpassSchedulingOracle.ml @@ -0,0 +1,1029 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +open Asmvliw +open Asmblock +open Printf +open Camlcoq +open InstructionScheduler +open TargetPrinter.Target + +let debug = false + +(** + * Extracting infos from Asmvliw instructions + *) + +type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset + +type location = Reg of preg | Mem + +type real_instruction = + (* ALU *) + | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sbfxw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw + | Addd | Andd | Compd | Muld | Ord | Sbfd | Sbfxd | Srad | Srld | Slld | Srsd | Xord + | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd + | Maddw | Maddd | Msbfw | Msbfd | Cmoved + | Make | Nop | Extfz | Extfs | Insf + | Addxw | Addxd + (* LSU *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo + | Sb | Sh | Sw | Sd | Sq | So + (* BCU *) + | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set + (* FPU *) + | Fabsd | Fabsw | Fnegw | Fnegd + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw + | Fmind | Fminw | Fmaxd | Fmaxw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd + | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz + | Fcompw | Fcompd + +type ab_inst_rec = { + inst: real_instruction; + write_locs : location list; + read_locs : location list; + read_at_id : location list; (* Must be contained in read_locs *) + read_at_e1 : location list; (* idem *) + imm : immediate option; + is_control : bool; +} + +(** Asmvliw constructor to real instructions *) + +exception OpaqueInstruction + +let arith_rr_real = function + | Pcvtl2w -> Addw + | Pmv -> Addd + | Pnegw -> Sbfw + | Pnegl -> Sbfd + | Psxwd -> Extfs + | Pzxwd -> Extfz + | Pextfz(_,_) -> Extfz + | Pextfs(_,_) -> Extfs + | Pextfzl(_,_) -> Extfz + | Pextfsl(_,_) -> Extfs + | Pfabsw -> Fabsw + | Pfabsd -> Fabsd + | Pfnegw -> Fnegw + | Pfnegd -> Fnegd + | Pfinvw -> Finvw + | Pfnarrowdw -> Fnarrowdw + | Pfwidenlwd -> Fwidenlwd + | Pfloatwrnsz -> Floatwz + | Pfloatuwrnsz -> Floatuwz + | Pfloatudrnsz -> Floatudz + | Pfloatdrnsz -> Floatdz + | Pfixedwrzz -> Fixedwz + | Pfixeduwrzz -> Fixeduwz + | Pfixeddrzz -> Fixeddz + | Pfixedudrzz -> Fixedudz + | Pfixeddrzz_i32 -> Fixeddz + | Pfixedudrzz_i32 -> Fixedudz + +let arith_rrr_real = function + | Pcompw it -> Compw + | Pcompl it -> Compd + | Pfcompw ft -> Fcompw + | Pfcompl ft -> Fcompd + | Paddw -> Addw + | Paddxw _ -> Addxw + | Psubw -> Sbfw + | Prevsubxw _ -> Sbfxw + | Pmulw -> Mulw + | Pandw -> Andw + | Pnandw -> Nandw + | Porw -> Orw + | Pnorw -> Norw + | Pxorw -> Xorw + | Pnxorw -> Nxorw + | Pandnw -> Andnw + | Pornw -> Ornw + | Psraw -> Sraw + | Psrlw -> Srlw + | Psrxw -> Srsw + | Psllw -> Sllw + | Paddl -> Addd + | Paddxl _ -> Addxd + | Psubl -> Sbfd + | Prevsubxl _ -> Sbfxd + | Pandl -> Andd + | Pnandl -> Nandd + | Porl -> Ord + | Pnorl -> Nord + | Pxorl -> Xord + | Pnxorl -> Nxord + | Pandnl -> Andnd + | Pornl -> Ornd + | Pmull -> Muld + | Pslll -> Slld + | Psrll -> Srld + | Psrxl -> Srsd + | Psral -> Srad + | Pfaddd -> Faddd + | Pfaddw -> Faddw + | Pfsbfd -> Fsbfd + | Pfsbfw -> Fsbfw + | Pfmuld -> Fmuld + | Pfmulw -> Fmulw + | Pfmind -> Fmind + | Pfminw -> Fminw + | Pfmaxd -> Fmaxd + | Pfmaxw -> Fmaxw + +let arith_rri32_real = function + | Pcompiw it -> Compw + | Paddiw -> Addw + | Paddxiw _ -> Addxw + | Prevsubiw -> Sbfw + | Prevsubxiw _ -> Sbfxw + | Pmuliw -> Mulw + | Pandiw -> Andw + | Pnandiw -> Nandw + | Poriw -> Orw + | Pnoriw -> Norw + | Pxoriw -> Xorw + | Pnxoriw -> Nxorw + | Pandniw -> Andnw + | Porniw -> Ornw + | Psraiw -> Sraw + | Psrxiw -> Srsw + | Psrliw -> Srlw + | Pslliw -> Sllw + | Proriw -> Rorw + | Psllil -> Slld + | Psrlil -> Srld + | Psrail -> Srad + | Psrxil -> Srsd + +let arith_rri64_real = function + | Pcompil it -> Compd + | Paddil -> Addd + | Prevsubil -> Sbfd + | Paddxil _ -> Addxd + | Prevsubxil _ -> Sbfxd + | Pmulil -> Muld + | Pandil -> Andd + | Pnandil -> Nandd + | Poril -> Ord + | Pnoril -> Nord + | Pxoril -> Xord + | Pnxoril -> Nxord + | Pandnil -> Andnd + | Pornil -> Ornd + + +let arith_arr_real = function + | Pinsf (_, _) -> Insf + | Pinsfl (_, _) -> Insf + +let arith_arrr_real = function + | Pfmaddfw -> Ffmaw + | Pfmaddfl -> Ffmad + | Pfmsubfw -> Ffmsw + | Pfmsubfl -> Ffmsd + | Pmaddw -> Maddw + | Pmaddl -> Maddd + | Pmsubw -> Msbfw + | Pmsubl -> Msbfd + | Pcmove _ -> Cmoved + | Pcmoveu _ -> Cmoved + +let arith_arri32_real = function + | Pmaddiw -> Maddw + | Pcmoveiw _ -> Cmoved + | Pcmoveuiw _ -> Cmoved + +let arith_arri64_real = function + | Pmaddil -> Maddd + | Pcmoveil _ -> Cmoved + | Pcmoveuil _ -> Cmoved + +let arith_ri32_real = Make + +let arith_ri64_real = Make + +let arith_rf32_real = Make + +let arith_rf64_real = Make + +let store_real = function + | Psb -> Sb + | Psh -> Sh + | Psw -> Sw + | Psw_a -> Sw + | Psd -> Sd + | Psd_a -> Sd + | Pfss -> Sw + | Pfsd -> Sd + +let load_real = function + | Plb -> Lbs + | Plbu -> Lbz + | Plh -> Lhs + | Plhu -> Lhz + | Plw -> Lws + | Plw_a -> Lws + | Pld -> Ld + | Pld_a -> Ld + | Pfls -> Lws + | Pfld -> Ld + +let set_real = Set +let get_real = Get +let nop_real = Nop +let loadsymbol_real = Make +let loadqrro_real = Lq +let loadorro_real = Lo +let storeqrro_real = Sq +let storeorro_real = So + +let ret_real = Ret +let call_real = Call +let icall_real = Icall +let goto_real = Goto +let igoto_real = Igoto +let jl_real = Goto +let cb_real = Cb +let cbu_real = Cb + +let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_arri32_rec i rd rs imm32 = + let rae1 = match i with Pmaddiw -> [Reg rd] | _ -> [] + in { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false; + read_at_id = [] ; read_at_e1 = rae1 } + +let arith_arri64_rec i rd rs imm64 = + let rae1 = match i with Pmaddil -> [Reg rd] | _ -> [] + in { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false; + read_at_id = []; read_at_e1 = rae1 } + +let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_arrr_rec i rd rs1 rs2 = + let rae1 = match i with Pmaddl | Pmaddw | Pmsubl | Pmsubw -> [Reg rd] | _ -> [] + in { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = rae1 } + +let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let arith_r_rec i rd = match i with + (* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *) + | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); + is_control = false; read_at_id = []; read_at_e1 = [] } + +let arith_rec i = + match i with + | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) + | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) + | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) + | PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs) + (* Seems like single constant constructor types are elided *) + | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) + | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) + | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) + | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = []; + imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} + | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = []; + imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} + | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) + | PArithR (i, rd) -> arith_r_rec i (IR rd) + +let load_rec i = match i with + | PLoadRRO (trap, i, rs1, rs2, imm) -> + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PLoadQRRO(rs, ra, imm) -> + let (rs0, rs1) = gpreg_q_expand rs in + { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; + read_at_id = []; read_at_e1 = [] } + | PLoadORRO(rs, ra, imm) -> + let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in + { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; + imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} + | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) -> + { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let store_rec i = match i with + | PStoreRRO (i, rs, ra, imm) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs)] ; is_control = false} + | PStoreQRRO (rs, ra, imm) -> + let (rs0, rs1) = gpreg_q_expand rs in + { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)); + read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1)] ; is_control = false} + | PStoreORRO (rs, ra, imm) -> + let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in + { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; + imm = (Some (Off imm)); read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; is_control = false} + | PStoreRRR (i, rs, ra1, ra2) | PStoreRRRXS (i, rs, ra1, ra2) -> + { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra1); Reg (IR ra2)]; imm = None; + read_at_id = []; read_at_e1 = [Reg (IR rs)]; is_control = false} + +let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false; + read_at_id = []; read_at_e1 = [] } + +let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + +let basic_rec i = + match i with + | PArith i -> arith_rec i + | PLoad i -> load_rec i + | PStore i -> store_rec i + | Pallocframe (_, _) -> raise OpaqueInstruction + | Pfreeframe (_, _) -> raise OpaqueInstruction + | Pget (rd, rs) -> get_rec rd rs + | Pset (rd, rs) -> set_rec rd rs + | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []} + +let expand_rec = function + | Pbuiltin _ -> raise OpaqueInstruction + +let ctl_flow_rec = function + | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []} + | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true; + read_at_id = [Reg (IR r)]; read_at_e1 = [] } + | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} + | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; + read_at_id = [Reg (IR rs)]; read_at_e1 = [] } + | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) + +let control_rec i = + match i with + | PExpand i -> expand_rec i + | PCtlFlow i -> ctl_flow_rec i + +let rec basic_recs body = match body with + | [] -> [] + | bi :: body -> (basic_rec bi) :: (basic_recs body) + +let exit_rec exit = match exit with + | None -> [] + | Some ex -> [control_rec ex] + +let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) + +(** + * Providing informations relative to the real instructions + *) + +(** Abstraction providing all the necessary informations for solving the scheduling problem *) +type inst_info = { + write_locs : location list; + read_locs : location list; + reads_at_id : bool; + reads_at_e1 : bool; + is_control : bool; + usage: int array; (* resources consumed by the instruction *) + latency: int; +} + +(** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) +type imm_encoding = U6 | S10 | U27L5 | U27L10 | E27U27L10 + +let rec pow a = function + | 0 -> Int64.one + | 1 -> Int64.of_int a + | n -> let b = pow a (n/2) in + Int64.mul b (Int64.mul b (if n mod 2 = 0 then Int64.one else Int64.of_int a)) + +let signed_interval n : (int64 * int64) = begin + assert (n > 0); + let min = Int64.neg @@ pow 2 (n-1) + and max = Int64.sub (pow 2 (n-1)) Int64.one + in (min, max) +end + +let within i interv = match interv with (min, max) -> (i >= min && i <= max) + +let signed_length (i:int64) = + let rec f (i:int64) n = + let interv = signed_interval n + in if (within i interv) then n else f i (n+1) + in f i 1 + +let unsigned_length (i:int64) = (signed_length i) - 1 + +let encode_imm (imm:int64) = + if (Int64.compare imm Int64.zero < 0) then + let length = signed_length imm + in if length <= 10 then S10 + else if length <= 32 then U27L5 + else if length <= 37 then U27L10 + else if length <= 64 then E27U27L10 + else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm + else + let length = unsigned_length imm + in if length <= 6 then U6 + else if length <= 9 then S10 (* Special case for S10 - stay signed no matter what *) + else if length <= 32 then U27L5 + else if length <= 37 then U27L10 + else if length <= 64 then E27U27L10 + else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm + +(** Resources *) +type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop + +let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop] + +let rec find_index elt l = + match l with + | [] -> raise Not_found + | e::l -> if (e == elt) then 0 + else 1 + find_index elt l + +let resource_id resource : int = find_index resource resource_names + +let resource_bound resource : int = + match resource with + | Rissue -> 8 + | Rtiny -> 4 + | Rlite -> 2 + | Rfull -> 1 + | Rlsu -> 1 + | Rmau -> 1 + | Rbcu -> 1 + | Rtca -> 1 + | Rauxr -> 1 + | Rauxw -> 1 + | Rcrrp -> 1 + | Rcrwl -> 1 + | Rcrwh -> 1 + | Rnop -> 4 + +let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) + +(** Reservation tables *) +let alu_full : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_lite : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_lite_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_lite_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_nop : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rnop -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_tiny : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_tiny_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let alu_tiny_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let bcu : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rbcu -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxw : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxw_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let lsu_auxw_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr : int array = let resmap = fun r -> match r with + | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_x : int array = let resmap = fun r -> match r with + | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +let mau_auxr_y : int array = let resmap = fun r -> match r with + | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 + in Array.of_list (List.map resmap resource_names) + +(** Real instructions *) + +exception InvalidEncoding + +let rec_to_usage r = + let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i) + | Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) + + in match r.inst with + | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw + | Nxorw | Andnw | Ornw -> + (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | _ -> raise InvalidEncoding) + | Sbfxw | Sbfxd -> + (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord + | Nxord | Andnd | Ornd -> + (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y) + |Cmoved -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) + | Addxw -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Addxd -> + (match encoding with None | Some U6 | Some S10 -> alu_lite + | Some U27L5 | Some U27L10 -> alu_lite_x + | Some E27U27L10 -> alu_lite_y) + | Compw -> (match encoding with None -> alu_tiny + | Some U6 | Some S10 | Some U27L5 -> alu_tiny_x + | _ -> raise InvalidEncoding) + | Compd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y) + | Fcompw -> (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Fcompd -> (match encoding with None -> alu_lite + | Some U6 | Some S10 | Some U27L5 -> alu_lite_x + | _ -> raise InvalidEncoding) + | Make -> (match encoding with Some U6 | Some S10 -> alu_tiny + | Some U27L5 | Some U27L10 -> alu_tiny_x + | Some E27U27L10 -> alu_tiny_y + | _ -> raise InvalidEncoding) + | Maddw -> (match encoding with None -> mau_auxr + | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x + | _ -> raise InvalidEncoding) + | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr + | Some U27L5 | Some U27L10 -> mau_auxr_x + | Some E27U27L10 -> mau_auxr_y) + | Mulw| Msbfw -> (match encoding with None -> mau + | Some U6 | Some S10 | Some U27L5 -> mau_x + | _ -> raise InvalidEncoding) + | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau + | Some U27L5 | Some U27L10 -> mau_x + | Some E27U27L10 -> mau_y) + | Nop -> alu_nop + | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) + (* TODO: check *) + | Srsw | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) + | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) + | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> + (match encoding with None | Some U6 | Some S10 -> lsu_auxw + | Some U27L5 | Some U27L10 -> lsu_auxw_x + | Some E27U27L10 -> lsu_auxw_y) + | Sb | Sh | Sw | Sd | Sq | So -> + (match encoding with None | Some U6 | Some S10 -> lsu_auxr + | Some U27L5 | Some U27L10 -> lsu_auxr_x + | Some E27U27L10 -> lsu_auxr_y) + | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu + | Get -> bcu_tiny_tiny_mau_xnop + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd + | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite + | Fnarrowdw -> alu_full + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau + + +let inst_info_to_dlatency i = + begin + assert (not (i.reads_at_id && i.reads_at_e1)); + match i.reads_at_id with + | true -> +1 + | false -> (match i.reads_at_e1 with + | true -> -1 + | false -> 0) + end + +let real_inst_to_latency = function + | Nop -> 0 (* Only goes through ID *) + | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw + (* TODO check rorw *) + | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw + | Nandd | Nord | Nxord | Ornd | Andnd + | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make + | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd + | Fmind | Fmaxd | Fminw | Fmaxw + -> 1 + | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 + | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) + | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> 3 + | Sb | Sh | Sw | Sd | Sq | So -> 1 (* See kvx-Optimization.pdf page 19 *) + | Get -> 1 + | Set -> 4 (* According to the manual should be 3, but I measured 4 *) + | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) + | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 + | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw + | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4 + +let rec empty_inter la = function + | [] -> true + | b::lb -> if (List.mem b la) then false else empty_inter la lb + +let rec_to_info r : inst_info = + let usage = rec_to_usage r + and latency = real_inst_to_latency r.inst + and reads_at_id = not (empty_inter r.read_locs r.read_at_id) + and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1) + in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control; + reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 } + +let instruction_infos bb = List.map rec_to_info (instruction_recs bb) + +let instruction_usages bb = + let usages = List.map (fun info -> info.usage) (instruction_infos bb) + in Array.of_list usages + +(** + * Latency constraints building + *) + +(* type access = { inst: int; loc: location } *) + +let preg2int pr = Camlcoq.P.to_int @@ Asmblockdeps.ppos pr + +let loc2int = function + | Mem -> 1 + | Reg pr -> preg2int pr + +(* module HashedLoc = struct + type t = { loc: location; key: int } + let equal l1 l2 = (l1.key = l2.key) + let hash l = l.key + let create (l:location) : t = { loc=l; key = loc2int l } +end *) + +(* module LocHash = Hashtbl.Make(HashedLoc) *) +module LocHash = Hashtbl + +(* Hash table : location => list of instruction ids *) + +let rec intlist n = + if n < 0 then failwith "intlist: n < 0" + else if n = 0 then [] + else (n-1) :: (intlist (n-1)) + +let find_in_hash hashloc loc = + match LocHash.find_opt hashloc loc with + | Some idl -> idl + | None -> [] + +(* Returns a list of instruction ids *) +let rec get_accesses hashloc (ll: location list) = match ll with + | [] -> [] + | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) + +let compute_latency (ifrom: inst_info) (ito: inst_info) = + let dlat = inst_info_to_dlatency ito + in let lat = ifrom.latency + dlat + in assert (lat >= 0); if (lat == 0) then 1 else lat + +let latency_constraints bb = + let written = LocHash.create 70 + and read = LocHash.create 70 + and count = ref 0 + and constraints = ref [] + and instr_infos = instruction_infos bb + in let step (i: inst_info) = + let raw = get_accesses written i.read_locs + and waw = get_accesses written i.write_locs + and war = get_accesses read i.write_locs + in begin + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; + latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw; + List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; + if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); + (* Updating "read" and "written" hashmaps *) + List.iter (fun loc -> + begin + LocHash.replace written loc [!count]; + LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) + end) i.write_locs; + List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs; + count := !count + 1 + end + in (List.iter step instr_infos; !constraints) + +(** + * Using the InstructionScheduler + *) + +let build_problem bb = + { max_latency = -1; resource_bounds = resource_bounds; + instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } + +let rec find_min_opt (l: int option list) = + match l with + | [] -> None + | e :: l -> + begin match find_min_opt l with + | None -> e + | Some m -> + begin match e with + | None -> Some m + | Some n -> if n < m then Some n else Some m + end + end + +let rec filter_indexes predicate = function + | [] -> [] + | e :: l -> if (predicate e) then e :: (filter_indexes predicate l) else filter_indexes predicate l + +let get_from_indexes indexes l = List.map (List.nth l) indexes + +let is_basic = function PBasic _ -> true | _ -> false +let is_control = function PControl _ -> true | _ -> false +let to_basic = function PBasic i -> i | _ -> failwith "to_basic: control instruction found" +let to_control = function PControl i -> i | _ -> failwith "to_control: basic instruction found" + +let bundlize li hd = + let last = List.nth li (List.length li - 1) + in if is_control last then + let cut_li = Array.to_list @@ Array.sub (Array.of_list li) 0 (List.length li - 1) + in let bli = List.map to_basic cut_li + in { header = hd; body = bli; exit = Some (to_control last) } + else + let bli = List.map to_basic li + in { header = hd; body = bli; exit = None } + +let apply_pbasic b = PBasic b +let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found" + +let rec find_min = function + | [] -> None + | e :: l -> + match find_min l with + | None -> Some e + | Some m -> if (e < m) then Some e else Some m + +let rec remove_all m = function + | [] -> [] + | e :: l -> if m=e then remove_all m l + else e :: (remove_all m l) + +let rec find_mins l = match find_min l with + | None -> [] + | Some m -> m :: find_mins (remove_all m l) + +let find_all_indices m l = + let rec find m off = function + | [] -> [] + | e :: l -> if m=e then off :: find m (off+1) l + else find m (off+1) l + in find m 0 l + +module TimeHash = Hashtbl + +(* Hash table : time => list of instruction ids *) + +let hashtbl2list h maxint = + let rec f i = match TimeHash.find_opt h i with + | None -> if (i > maxint) then [] else (f (i+1)) + | Some bund -> bund :: (f (i+1)) + in f 0 + +let find_max l = + let rec f = function + | [] -> None + | e :: l -> match f l with + | None -> Some e + | Some m -> if (e > m) then Some e else Some m + in match (f l) with + | None -> raise Not_found + | Some m -> m + +(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) +let minpack_list (l: int list) = + let timehash = TimeHash.create (List.length l) + in let rec f i = function + | [] -> () + | t::l -> begin + (match TimeHash.find_opt timehash t with + | None -> TimeHash.add timehash t [i] + | Some bund -> TimeHash.replace timehash t (bund @ [i])); + f (i+1) l + end + in begin + f 0 l; + hashtbl2list timehash (find_max l) + end;; + +(* let minpack_list l = + let mins = find_mins l + in List.map (fun m -> find_all_indices m l) mins + *) + +let bb_to_instrs bb = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) + +let bundlize_solution bb sol = + let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) + in let packs = minpack_list tmp + and instrs = bb_to_instrs bb + in let rec bund hd = function + | [] -> [] + | pack :: packs -> bundlize (get_from_indexes pack instrs) hd :: (bund [] packs) + in bund bb.header packs + +let print_inst oc = function + | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" + | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" + | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" + | Asm.Pcvtl2w(rd, rs) -> fprintf oc " Pcvtl2w %a = %a\n" ireg rd ireg rs + | i -> print_instruction oc i + +let print_bb oc bb = + let asm_instructions = Asm.unfold_bblock bb + in List.iter (print_inst oc) asm_instructions + +let do_schedule bb = + let problem = build_problem bb + in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then + validated_scheduler cascaded_scheduler + else if !Clflags.option_fpostpass_sched = "list" then + validated_scheduler list_scheduler + else if !Clflags.option_fpostpass_sched = "revlist" then + validated_scheduler reverse_list_scheduler + else if !Clflags.option_fpostpass_sched = "greedy" then + greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem + in match solution with + | None -> failwith "Could not find a valid schedule" + | Some sol -> let bundles = bundlize_solution bb sol in + (if debug then + begin + Printf.eprintf "Scheduling the following group of instructions:\n"; + print_bb stderr bb; + Printf.eprintf "Gave the following solution:\n"; + List.iter (print_bb stderr) bundles; + Printf.eprintf "--------------------------------\n" + end; + bundles) + +(** + * Dumb schedule if the above doesn't work + *) + +let bundlize_label l = + match l with + | [] -> [] + | l -> [{ header = l; body = []; exit = None }] + +let rec bundlize_basic l = + match l with + | [] -> [] + | b :: l -> { header = []; body = [b]; exit = None } :: bundlize_basic l + +let bundlize_exit e = + match e with + | Some e -> [{ header = []; body = []; exit = Some e }] + | None -> [] + +let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit + +(** + * Separates the opaque instructions such as Pfreeframe and Pallocframe + *) + +let is_opaque = function + | PBasic (Pallocframe _) | PBasic (Pfreeframe _) | PControl (PExpand (Pbuiltin _)) -> true + | _ -> false + +(* Returns : (accumulated instructions, remaining instructions, opaque instruction if found) *) +let rec biggest_wo_opaque = function + | [] -> ([], [], None) + | i :: li -> if is_opaque i then ([], li, Some i) + else let big, rem, opaque = biggest_wo_opaque li in (i :: big, rem, opaque);; + +let separate_opaque bb = + let instrs = bb_to_instrs bb + in let rec f hd li = + match li with + | [] -> [] + | li -> let big, rem, opaque = biggest_wo_opaque li in + match opaque with + | Some i -> + (match big with + | [] -> (bundlize [i] hd) :: (f [] rem) + | big -> (bundlize big hd) :: (bundlize [i] []) :: (f [] rem) + ) + | None -> (bundlize big hd) :: (f [] rem) + in f bb.header instrs + +let smart_schedule bb = + let lbb = separate_opaque bb + in let rec f = function + | [] -> [] + | bb :: lbb -> + let bundles = + try do_schedule bb + with OpaqueInstruction -> dumb_schedule bb + | e -> + let msg = Printexc.to_string e + and stack = Printexc.get_backtrace () + in begin + Printf.eprintf "In regards to this group of instructions:\n"; + print_bb stderr bb; + Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; + failwith "Invalid schedule" + (* + Printf.eprintf "Issuing one instruction per bundle instead\n\n"; + dumb_schedule bb + *) + end + in bundles @ (f lbb) + in f lbb + +let bblock_to_bundles bb = + if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); + (* print_problem (build_problem bb); *) + if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb + +(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *) + +let rec bundles_to_coq_schedule = function + | [] -> ([], None) + | bb :: [] -> ([bb.body], bb.exit) + | bb :: lbb -> let (llb, oc) = bundles_to_coq_schedule lbb in (bb.body :: llb, oc) + +(** Called schedule function from Coq *) + +let schedule_notime bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto +let schedule bb = Timing.time_coq ('P'::('o'::('s'::('t'::('p'::('a'::('s'::('s'::('S'::('c'::('h'::('e'::('d'::('u'::('l'::('i'::('n'::('g'::(' '::('o'::('r'::('a'::('c'::('l'::('e'::([])))))))))))))))))))))))))) schedule_notime bb diff --git a/kvx/PostpassSchedulingproof.v b/kvx/PostpassSchedulingproof.v new file mode 100644 index 00000000..c290387b --- /dev/null +++ b/kvx/PostpassSchedulingproof.v @@ -0,0 +1,689 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Machblock Conventions Asmblock. +Require Import Asmblockgenproof0 Asmblockprops. +Require Import PostpassScheduling. +Require Import Asmblockgenproof. +Require Import Axioms. + +Local Open Scope error_monad_scope. + +Definition match_prog (p tp: Asmvliw.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + +Lemma regset_double_set_id: + forall r (rs: regset) v1 v2, + (rs # r <- v1 # r <- v2) = (rs # r <- v2). +Proof. + intros. apply functional_extensionality. intros. destruct (preg_eq r x). + - subst r. repeat (rewrite Pregmap.gss; auto). + - repeat (rewrite Pregmap.gso); auto. +Qed. + +Lemma exec_body_pc_var: + forall l ge rs m rs' m' v, + exec_body ge l rs m = Next rs' m' -> + exec_body ge l (rs # PC <- v) m = Next (rs' # PC <- v) m'. +Proof. + induction l. + - intros. simpl. simpl in H. inv H. auto. + - intros. simpl in *. + destruct (exec_basic_instr ge a rs m) eqn:EXEBI; try discriminate. + erewrite exec_basic_instr_pc_var; eauto. +Qed. + +Lemma pc_set_add: + forall rs v r x y, + 0 <= x <= Ptrofs.max_unsigned -> + 0 <= y <= Ptrofs.max_unsigned -> + rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). +Proof. + intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). + - subst. repeat (rewrite Pregmap.gss); auto. + destruct v; simpl; auto. + rewrite Ptrofs.add_assoc. + enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto. + unfold Ptrofs.add. + enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto. + repeat (rewrite Ptrofs.unsigned_repr); auto. + - repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma concat2_straight: + forall a b bb rs m rs'' m'' f ge, + concat2 a b = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists rs' m', + exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f b rs' m' = Next rs'' m''. +Proof. + intros until ge. intros CONC2 EXEB. + exploit concat2_zlt_size; eauto. intros (LTA & LTB). + exploit concat2_noexit; eauto. intros EXA. + exploit concat2_decomp; eauto. intros. inv H. + unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. + rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). + eexists; eexists. split. + unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. + split. + exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. + unfold exec_bblock. unfold nextblock, incrPC. rewrite regset_same_assign. erewrite exec_body_pc_var; eauto. + rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. + assert (size bb = size a + size b). + { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. + repeat (rewrite Nat2Z.inj_add). omega. } + clear EXA H0 H1. rewrite H in EXEB. + assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } + rewrite H0. rewrite <- pc_set_add; auto. + exploit size_positive. instantiate (1 := a). intro. omega. + exploit size_positive. instantiate (1 := b). intro. omega. +Qed. + +Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : + forall a bb rs m lbb rs'' m'', + lbb <> nil -> + concat_all (a :: lbb) = OK bb -> + exec_bblock ge f bb rs m = Next rs'' m'' -> + exists bb' rs' m', + concat_all lbb = OK bb' + /\ exec_bblock ge f a rs m = Next rs' m' + /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) + /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. +Proof. + intros until m''. intros Hnonil CONC EXEB. + simpl in CONC. + destruct lbb as [|b lbb]; try contradiction. clear Hnonil. + monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). + exists x. repeat econstructor. all: eauto. +Qed. + +Lemma ptrofs_add_repr : + forall a b, + Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). +Proof. + intros a b. + rewrite Ptrofs.add_unsigned. repeat (rewrite Ptrofs.unsigned_repr_eq). + rewrite <- Zplus_mod. auto. +Qed. + +Section PRESERVATION_ASMBLOCK. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma transf_function_no_overflow: + forall f tf, + transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. +Proof. + intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. + omega. +Qed. + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_match TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). + +Lemma functions_translated: + forall v f, + Genv.find_funct ge v = Some f -> + exists tf, + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial TRANSL). + +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists tf, + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSL). + +Lemma functions_transl: + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transf_function f = OK tf -> + Genv.find_funct_ptr tge fb = Some (Internal tf). +Proof. + intros. exploit function_ptr_translated; eauto. + intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. +Qed. + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s1 s2, s1 = s2 -> match_states s1 s2. + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSL). + +Lemma prog_main_address_preserved: + (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = + (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). +Proof. + unfold Genv.symbol_address. rewrite symbols_preserved. + rewrite prog_main_preserved. auto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inv H. + econstructor; split. + - eapply initial_state_intro. + eapply (Genv.init_mem_transf_partial TRANSL); eauto. + - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> final_state st1 r -> final_state st2 r. +Proof. + intros. inv H0. inv H. econstructor; eauto. +Qed. + +Lemma tail_find_bblock: + forall lbb pos bb, + find_bblock pos lbb = Some bb -> + exists c, code_tail pos lbb (bb::c). +Proof. + induction lbb. + - intros. simpl in H. inv H. + - intros. simpl in H. + destruct (zlt pos 0); try (inv H; fail). + destruct (zeq pos 0). + + inv H. exists lbb. constructor; auto. + + apply IHlbb in H. destruct H as (c & TAIL). exists c. + enough (pos = pos - size a + size a) as ->. + apply code_tail_S; auto. + omega. +Qed. + +Lemma code_tail_head_app: + forall l pos c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + size_blocks l) (l++c1) c2. +Proof. + induction l. + - intros. simpl. rewrite Z.add_0_r. auto. + - intros. apply IHl in H. simpl. rewrite (Z.add_comm (size a)). rewrite Z.add_assoc. apply code_tail_S. assumption. +Qed. + +Lemma transf_blocks_verified: + forall c tc pos bb c', + transf_blocks c = OK tc -> + code_tail pos c (bb::c') -> + exists lbb, + verified_schedule bb = OK lbb + /\ exists tc', code_tail pos tc (lbb ++ tc'). +Proof. + induction c; intros. + - simpl in H. inv H. inv H0. + - inv H0. + + monadInv H. exists x0. + split; simpl; auto. eexists; eauto. econstructor; eauto. + + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. + exploit IHc; eauto. + intros (lbb & TRANS & tc' & TAIL). +(* monadInv TRANS. *) + repeat eexists; eauto. + erewrite verified_schedule_size; eauto. + apply code_tail_head_app. + eauto. +Qed. + +Lemma transf_find_bblock: + forall ofs f bb tf, + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> + transf_function f = OK tf -> + exists lbb, + verified_schedule bb = OK lbb + /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). +Proof. + intros. + monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. + monadInv EQ. apply tail_find_bblock in H. destruct H as (c & TAIL). + eapply transf_blocks_verified; eauto. +Qed. + +Lemma symbol_address_preserved: + forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. +Proof. + intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. +Qed. + +Lemma head_tail {A: Type}: + forall (l: list A) hd, hd::l = hd :: (tail (hd::l)). +Proof. + intros. simpl. auto. +Qed. + +Lemma verified_schedule_not_empty: + forall bb lbb, + verified_schedule bb = OK lbb -> lbb <> nil. +Proof. + intros. apply verified_schedule_size in H. + pose (size_positive bb). assert (size_blocks lbb > 0) by omega. clear H g. + destruct lbb; simpl in *; discriminate. +Qed. + +Lemma header_nil_label_pos_none: + forall lbb l p, + Forall (fun b => header b = nil) lbb -> label_pos l p lbb = None. +Proof. + induction lbb. + - intros. simpl. auto. + - intros. inv H. simpl. unfold is_label. rewrite H2. destruct (in_dec l nil). { inv i. } + auto. +Qed. + +Lemma verified_schedule_label: + forall bb tbb lbb l, + verified_schedule bb = OK (tbb :: lbb) -> + is_label l bb = is_label l tbb + /\ label_pos l 0 lbb = None. +Proof. + intros. exploit verified_schedule_header; eauto. + intros (HdrEq & HdrNil). + split. + - unfold is_label. rewrite HdrEq. reflexivity. + - apply header_nil_label_pos_none. assumption. +Qed. + +Lemma label_pos_app_none: + forall c c' l p p', + label_pos l p c = None -> + label_pos l (p' + size_blocks c) c' = label_pos l p' (c ++ c'). +Proof. + induction c. + - intros. simpl in *. rewrite Z.add_0_r. reflexivity. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLABEL. + + discriminate. + + eapply IHc in H. rewrite Z.add_assoc. eauto. +Qed. + +Remark label_pos_pvar_none_add: + forall tc l p p' k, + label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. +Proof. + induction tc. + - intros. simpl. auto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + discriminate. + + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_none: + forall tc l p p', + label_pos l p tc = None -> label_pos l p' tc = None. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_none_add; eauto. +Qed. + +Remark label_pos_pvar_some_add_add: + forall tc l p p' k k', + label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). +Proof. + induction tc. + - intros. simpl in H. discriminate. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + inv H. assert (k = k') by omega. subst. reflexivity. + + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar_some_add: + forall tc l p p' k, + label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_some_add_add; eauto. +Qed. + +Remark label_pos_pvar_add: + forall c tc l p p' k, + label_pos l (p+k) c = label_pos l p tc -> + label_pos l (p'+k) c = label_pos l p' tc. +Proof. + induction c. + - intros. simpl in *. + exploit label_pos_pvar_none; eauto. + - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. + + exploit label_pos_pvar_some_add; eauto. + + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. +Qed. + +Lemma label_pos_pvar: + forall c tc l p p', + label_pos l p c = label_pos l p tc -> + label_pos l p' c = label_pos l p' tc. +Proof. + intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. + eapply label_pos_pvar_add; eauto. +Qed. + +Lemma label_pos_head_app: + forall c bb lbb l tc p, + verified_schedule bb = OK lbb -> + label_pos l p c = label_pos l p tc -> + label_pos l p (bb :: c) = label_pos l p (lbb ++ tc). +Proof. + intros. simpl. destruct lbb as [|tbb lbb]. + - apply verified_schedule_not_empty in H. contradiction. + - simpl. exploit verified_schedule_label; eauto. intros (ISLBL & LBLPOS). + rewrite ISLBL. + destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. + eapply label_pos_pvar in H0. erewrite H0. + erewrite verified_schedule_size; eauto. simpl size_blocks. rewrite Z.add_assoc. + erewrite label_pos_app_none; eauto. +Qed. + +Lemma label_pos_preserved: + forall c tc l, + transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. +Proof. + induction c. + - intros. simpl in *. inv H. reflexivity. + - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. eapply IHc in EQ. + eapply label_pos_head_app; eauto. +Qed. + +Lemma label_pos_preserved_blocks: + forall l f tf, + transf_function f = OK tf -> + label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). +Proof. + intros. monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned _); try discriminate. + monadInv EQ0. simpl. eapply label_pos_preserved; eauto. +Qed. + +Lemma transf_exec_control: + forall f tf ex rs m, + transf_function f = OK tf -> + exec_control ge f ex rs m = exec_control tge tf ex rs m. +Proof. + intros. destruct ex; simpl; auto. + assert (ge = Genv.globalenv prog). auto. + assert (tge = Genv.globalenv tprog). auto. + pose symbol_address_preserved. + exploreInst; simpl; auto; try congruence; + unfold par_goto_label; unfold par_eval_branch; unfold par_goto_label; erewrite label_pos_preserved_blocks; eauto. +Qed. + +Lemma transf_exec_basic_instr: + forall i rs m, exec_basic_instr ge i rs m = exec_basic_instr tge i rs m. +Proof. + intros. pose symbol_address_preserved. + unfold exec_basic_instr. unfold bstep. exploreInst; simpl; auto; try congruence. + unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. +Qed. + +Lemma transf_exec_body: + forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. +Proof. + induction bdy; intros. + - simpl. reflexivity. + - simpl. rewrite transf_exec_basic_instr. + destruct (exec_basic_instr _ _ _); auto. +Qed. + +Lemma transf_exec_bblock: + forall f tf bb rs m, + transf_function f = OK tf -> + exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. +Proof. + intros. unfold exec_bblock. rewrite transf_exec_body. destruct (exec_body _ _ _ _); auto. + eapply transf_exec_control; eauto. +Qed. + +Lemma transf_step_simu: + forall tf b lbb ofs c tbb rs m rs' m', + Genv.find_funct_ptr tge b = Some (Internal tf) -> + size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned -> + rs PC = Vptr b ofs -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c) -> + concat_all lbb = OK tbb -> + exec_bblock tge tf tbb rs m = Next rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + induction lbb. + - intros until m'. simpl. intros. discriminate. + - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. + destruct lbb. + + simpl in *. clear IHlbb. inv CONC. eapply plus_one. econstructor; eauto. eapply find_bblock_tail; eauto. + + exploit concat_all_exec_bblock; eauto; try discriminate. + intros (tbb0 & rs0 & m0 & CONC0 & EXEB0 & PCeq' & EXEB1). + eapply plus_left. + econstructor. + 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. + all: eauto. + eapply plus_star. eapply IHlbb; eauto. rewrite PCeq in PCeq'. simpl in PCeq'. all: eauto. + eapply code_tail_next_int; eauto. +Qed. + +Theorem transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', plus step tge s1' t s2' /\ match_states s2 s2'). +Proof. + induction 1; intros; inv MS. + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). + exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). inv CONC. rename H3 into CONC. + assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). + eapply transf_function_no_overflow; eauto. + + erewrite transf_exec_bblock in H2; eauto. + unfold bblock_simu in BBEQ. rewrite BBEQ in H2; try congruence. + exists (State rs' m'). split; try (constructor; auto). + eapply transf_step_simu; eauto. + + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). + exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. + + remember (State (nextblock _ _) _) as s'. exists s'. + split; try constructor; auto. + eapply plus_one. subst s'. + eapply exec_step_builtin. + 3: eapply find_bblock_tail. simpl in TAIL. 3: eauto. + all: eauto. + eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + + - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. + remember (State _ m') as s'. exists s'. split; try constructor; auto. + subst s'. eapply plus_one. eapply exec_step_external; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. +Qed. + +Theorem transf_program_correct_Asmblock: + forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). +Proof. + eapply forward_simulation_plus. + - apply senv_preserved. + - apply transf_initial_states. + - apply transf_final_states. + - apply transf_step_correct. +Qed. + +End PRESERVATION_ASMBLOCK. + +Require Import Asmvliw. + +Lemma verified_par_checks_alls_bundles lb x: forall bundle, + verify_par lb = OK x -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + induction lb; simpl; try tauto. + intros bundle H; monadInv H. + destruct 1; subst; eauto. + destruct x0; auto. +Qed. + +Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: + verified_schedule_nob bb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + unfold verified_schedule_nob. intros H; + monadInv H. destruct x4. + intros; eapply verified_par_checks_alls_bundles; eauto. +Qed. + +Lemma verify_par_bblock_PExpand bb i: + exit bb = Some (PExpand i) -> verify_par_bblock bb = OK tt. +Proof. + destruct bb as [h bdy ext H]; simpl. + intros; subst. destruct i. + generalize H. + rewrite <- wf_bblock_refl in H. + destruct H as [H H0]. + unfold builtin_alone in H0. erewrite H0; eauto. +Qed. + +Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. + +Lemma verified_schedule_checks_alls_bundles bb lb bundle: + verified_schedule bb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + unfold verified_schedule. remember (exit bb) as exb. + destruct exb as [c|]; eauto. + destruct c as [i|]; eauto. + destruct i; intros H. inversion_clear H; simpl. + intuition subst. + intros; eapply verify_par_bblock_PExpand; eauto. +Qed. + +Lemma transf_blocks_checks_all_bundles lbb: forall lb bundle, + transf_blocks lbb = OK lb -> + List.In bundle lb -> verify_par_bblock bundle = OK tt. +Proof. + induction lbb; simpl. + - intros lb bundle H; inversion_clear H. simpl; try tauto. + - intros lb bundle H0. + monadInv H0. + rewrite in_app. destruct 1; eauto. + eapply verified_schedule_checks_alls_bundles; eauto. +Qed. + +Lemma find_bblock_Some_in lb: + forall ofs b, find_bblock ofs lb = Some b -> List.In b lb. +Proof. + induction lb; simpl; try congruence. + intros ofs b. + destruct (zlt ofs 0); try congruence. + destruct (zeq ofs 0); eauto. + intros X; inversion X; eauto. +Qed. + +Section PRESERVATION_ASMVLIW. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma all_bundles_are_checked b ofs f bundle: + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock ofs (fn_blocks f) = Some bundle -> + verify_par_bblock bundle = OK tt. +Proof. + unfold match_prog, match_program in TRANSL. + unfold Genv.find_funct_ptr; simpl; intros X. + destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. + destruct y as [tf0|]; try congruence. + inversion X as [H1]. subst. clear X. + remember (@Gfun fundef unit (Internal f)) as f2. + destruct H as [ctx' f1 f2 H0|]; try congruence. + inversion Heqf2 as [H2]. subst; clear Heqf2. + unfold transf_fundef, transf_partial_fundef in H. + destruct f1 as [f1|f1]; try congruence. + unfold transf_function, transl_function in H. + monadInv H. monadInv EQ. + destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. + injection EQ1; intros; subst. + monadInv EQ0. simpl in * |-. + intros; exploit transf_blocks_checks_all_bundles; eauto. + intros; eapply find_bblock_Some_in; eauto. +Qed. + +Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m': + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + verify_par_bblock bundle = OK tt -> + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. +Proof. + intros. unfold verify_par_bblock in H0. destruct (Asmblockdeps.bblock_para_check _) eqn:BPC; try discriminate. clear H0. + simpl in H. + eapply Asmblockdeps.bblock_para_check_correct; eauto. +Qed. + +Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m': + Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> + find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> + exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> + det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. +Proof. + intros; eapply checked_bundles_are_parexec_equiv; eauto. + eapply all_bundles_are_checked; eauto. +Qed. + +Theorem transf_program_correct_Asmvliw: + forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). +Proof. + eapply forward_simulation_step with (match_states:=fun (s1:Asmvliw.state) s2 => s1=s2); eauto. + - intros; subst; auto. + - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. + + eapply exec_step_internal; eauto. + intros; eapply seqexec_parexec_equiv; eauto. + + eapply exec_step_builtin; eauto. + + eapply exec_step_external; eauto. +Qed. + +End PRESERVATION_ASMVLIW. + +Section PRESERVATION. + +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Theorem transf_program_correct: + forward_simulation (Asmblock.semantics prog) (Asmvliw.semantics tprog). +Proof. + eapply compose_forward_simulations. + eapply transf_program_correct_Asmblock; eauto. + eapply transf_program_correct_Asmvliw; eauto. +Qed. + +End PRESERVATION. diff --git a/kvx/PrintOp.ml b/kvx/PrintOp.ml new file mode 100644 index 00000000..da7d6c32 --- /dev/null +++ b/kvx/PrintOp.ml @@ -0,0 +1,229 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Pretty-printing of operators, conditions, addressing modes *) + +open Printf +open Camlcoq +open Integers +open Op +open ExtValues + +let comparison_name = function + | Ceq -> "==" + | Cne -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + +let print_condition reg pp = function + | (Ccomp c, [r1;r2]) -> + fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 + | (Ccompu c, [r1;r2]) -> + fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 + | (Ccompimm(c, n), [r1]) -> + fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompuimm(c, n), [r1]) -> + fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) + | (Ccompf c, [r1;r2]) -> + fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 + | (Ccompl c, [r1;r2]) -> + fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 + | (Ccomplu c, [r1;r2]) -> + fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 + | (Ccomplimm(c, n), [r1]) -> + fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Ccompluimm(c, n), [r1]) -> + fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) + | (Cnotcompf c, [r1;r2]) -> + fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 + | (Ccompfs c, [r1;r2]) -> + fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 + | (Cnotcompfs c, [r1;r2]) -> + fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 + | _ -> + fprintf pp "" + +let print_condition0 reg pp cond0 rc = + match cond0 with + | Ccomp0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccompu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + | Ccompl0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) + | Ccomplu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) + +let int_of_s14 = function + | SHIFT1 -> 1 + | SHIFT2 -> 2 + | SHIFT3 -> 3 + | SHIFT4 -> 4 + +let print_operation reg pp op = match op with + | Omove, [r1] -> reg pp r1 + | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) + | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) + | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) + | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) + | Oaddrsymbol(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Oaddrstack ofs, [] -> + fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) + | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 + | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 + | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) + | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 + | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) + | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 + | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 + | Orevsubimm(imm), [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 + | Orevsubx(s14), [r1; r2] -> fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) + | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) + | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 + | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) + | Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2 + | Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2 + | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 + | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 + | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 + | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2 + | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 + | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) + | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 + | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) + | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 + | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) + | Onxor, [r1;r2] -> fprintf pp "~(%a ^ %a)" reg r1 reg r2 + | Onxorimm n, [r1] -> fprintf pp "~(%a ^ %ld)" reg r1 (camlint_of_coqint n) + | Onot, [r1] -> fprintf pp "~%a" reg r1 + | Oandn, [r1; r2] -> fprintf pp "(~%a) & %a" reg r1 reg r2 + | Oandnimm n, [r1] -> fprintf pp "(~%a) & %ld" reg r1 (camlint_of_coqint n) + | Oorn, [r1;r2] -> fprintf pp "(~%a) | %a" reg r1 reg r2 + | Oornimm n, [r1] -> fprintf pp "(~%a) | %ld" reg r1 (camlint_of_coqint n) + | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 + | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) + | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 + | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) + | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 + | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) + | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) + | Ororimm n, [r1] -> fprintf pp "(%a ror %ld)" reg r1 (camlint_of_coqint n) + | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 + | Omaddimm imm, [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) + | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 + + | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 + | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 + | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 + | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 + | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 + | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 + | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) + | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 + | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%Ld -l (%a < fprintf pp "-l (%a)" reg r1 + | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 + | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 + | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) + | Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2 + | Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2 + | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 + | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 + | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 + | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 + | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 + | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) + | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 + | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) + | Onorl, [r1; r2] -> fprintf pp "~(%a |l %a)" reg r1 reg r2 + | Onorlimm n, [r1] -> fprintf pp "~(%a |l %Ld)" reg r1 (camlint64_of_coqint n) + | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 + | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) + | Onxorl, [r1;r2] -> fprintf pp "~(%a ^l %a)" reg r1 reg r2 + | Onxorlimm n, [r1] -> fprintf pp "~(%a ^l %Ld)" reg r1 (camlint64_of_coqint n) + | Onotl, [r1] -> fprintf pp "~%a" reg r1 + | Oandnl, [r1;r2] -> fprintf pp "(~%a) &l %a" reg r1 reg r2 + | Oandnlimm n, [r1] -> fprintf pp "(~%a) &l %Ld" reg r1 (camlint64_of_coqint n) + | Oornl, [r1;r2] -> fprintf pp "(~%a) |l %a" reg r1 reg r2 + | Oornlimm n, [r1;r2] -> fprintf pp "(~%a) |l %Ld" reg r1 (camlint64_of_coqint n) + | Oshll, [r1;r2] -> fprintf pp "%a < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 + | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) + | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 + | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) + | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) + | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 + | Omaddlimm imm, [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) + | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 + + | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 + | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 + | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 + | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 + | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 + | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 + | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1 + | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1 + | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2 + | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2 + | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2 + | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2 + | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 + | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 + | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 + | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 + | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 + | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 + | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 + | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 + | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 + | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 + | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 + | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 + | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 + | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 + | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 + | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 + | Ocmp c, args -> print_condition reg pp (c, args) + + | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oextfsl(stop, start), [r1] -> fprintf pp "extfsl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 + | Oinsf(stop, start), [r1; r2] -> fprintf pp "insf(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Oinsfl(stop, start), [r1; r2] -> fprintf pp "insfl(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 + | Osel(cond0, ty), [r1; r2; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %a" reg r1 reg r2 + | Oselimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a : %ld" reg r1 (camlint_of_coqint imm) + | Osellimm(cond0, imm), [r1; rc] -> + print_condition0 reg pp cond0 rc; + fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) + | _, _ -> fprintf pp "" + +let print_addressing reg pp = function + | Aindexed2XS scale, [r1;r2] -> fprintf pp "%a + (%a << %ld)" reg r1 reg r2 (camlint_of_coqint scale) + | Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 + | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) + | Aglobal(id, ofs), [] -> + fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) + | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) + | _ -> fprintf pp "" diff --git a/kvx/SelectLong.vp b/kvx/SelectLong.vp new file mode 100644 index 00000000..b3638eca --- /dev/null +++ b/kvx/SelectLong.vp @@ -0,0 +1,463 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Instruction selection for 64-bit integer operations *) + +Require Import Coqlib. +Require Import Compopts. +Require Import AST Integers Floats. +Require Import Op CminorSel. +Require Import OpHelpers. +Require Import SelectOp SplitLong. +Require Import ExtValues. +Require Import DecBoolOps. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Definition longconst (n: int64) : expr := + if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. + +Definition is_longconst (e: expr) := + if Archi.splitlong then SplitLong.is_longconst e else + match e with + | Eop (Olongconst n) Enil => Some n + | _ => None + end. + +Definition intoflong (e: expr) := + if Archi.splitlong then SplitLong.intoflong e else + match is_longconst e with + | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil + | None => Eop Olowlong (e ::: Enil) + end. + +Definition longofint (e: expr) := + if Archi.splitlong then SplitLong.longofint e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.signed n)) + | None => Eop Ocast32signed (e ::: Enil) + end. + +Definition longofintu (e: expr) := + if Archi.splitlong then SplitLong.longofintu e else + match is_intconst e with + | Some n => longconst (Int64.repr (Int.unsigned n)) + | None => Eop Ocast32unsigned (e ::: Enil) + end. + +(** ** Integer addition and pointer addition *) + +Definition addlimm_shllimm sh k2 e1 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) + | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil). + +Nondetfunction addlimm (n: int64) (e: expr) := + if Int64.eq n Int64.zero then e else + match e with + | Eop (Olongconst m) Enil => longconst (Int64.add n m) + | Eop (Oaddrsymbol s m) Enil => + (if Compopts.optim_globaladdroffset tt + then Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + else Eop (Oaddlimm n) (e ::: Enil)) + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil + | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) + | Eop (Oaddxlimm sh m) (t ::: Enil) => Eop (Oaddxlimm sh (Int64.add n m)) (t ::: Enil) + | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 + | _ => Eop (Oaddlimm n) (e ::: Enil) + end. + +Definition addl_shllimm n e1 e2 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) + | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) + end + else Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil). + +Nondetfunction addl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.addl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => + Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) + | t1, (Eop Omull (t2:::t3:::Enil)) => + Eop Omaddl (t1:::t2:::t3:::Enil) + | (Eop Omull (t2:::t3:::Enil)), t1 => + Eop Omaddl (t1:::t2:::t3:::Enil) + | t1, (Eop (Omullimm n) (t2:::Enil)) => + Eop (Omaddlimm n) (t1:::t2:::Enil) + | (Eop (Omullimm n) (t2:::Enil)), t1 => + Eop (Omaddlimm n) (t1:::t2:::Enil) + | (Eop (Oshllimm n) (t1:::Enil)), t2 => + addl_shllimm n t1 t2 + | t2, (Eop (Oshllimm n) (t1:::Enil)) => + addl_shllimm n t1 t2 + | _, _ => Eop Oaddl (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction subl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.subl e1 e2 else + match e1, e2 with + | t1, Eop (Olongconst n2) Enil => + addlimm (Int64.neg n2) t1 + | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) + | Eop (Oaddlimm n1) (t1:::Enil), t2 => + addlimm n1 (Eop Osubl (t1:::t2:::Enil)) + | t1, Eop (Oaddlimm n2) (t2:::Enil) => + addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) + | t1, (Eop Omull (t2:::t3:::Enil)) => + Eop Omsubl (t1:::t2:::t3:::Enil) + | t1, (Eop (Omullimm n) (t2:::Enil)) => + Eop (Omaddlimm (Int64.neg n)) (t1:::t2:::Enil) + | _, _ => Eop Osubl (e1:::e2:::Enil) + end. + +Definition negl (e: expr) := + if Archi.splitlong then SplitLong.negl e else + match is_longconst e with + | Some n => longconst (Int64.neg n) + | None => Eop Onegl (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shllimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shllimm e1 n else + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int64.iwordsize') then + Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shl' n1 n) + | Eop (Oshllimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshllimm n) (e1:::Enil) + | _ => + Eop (Oshllimm n) (e1:::Enil) + end. + +Nondetfunction shrluimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrluimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shru' n1 n) + | Eop (Oshrluimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | Eop (Oshllimm n1) (t1:::Enil) => + let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in + if is_bitfieldl stop start + then Eop (Oextfzl stop start) (t1:::Enil) + else Eop (Oshrluimm n) (e1:::Enil) + | _ => + Eop (Oshrluimm n) (e1:::Enil) + end. + +Nondetfunction shrlimm (e1: expr) (n: int) := + if Archi.splitlong then SplitLong.shrlimm e1 n else + if Int.eq n Int.zero then e1 else + if negb (Int.ltu n Int64.iwordsize') then + Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) + else + match e1 with + | Eop (Olongconst n1) Enil => + longconst (Int64.shr' n1 n) + | Eop (Oshrlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int64.iwordsize' + then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | Eop (Oshllimm n1) (t1:::Enil) => + let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in + if is_bitfieldl stop start + then Eop (Oextfsl stop start) (t1:::Enil) + else Eop (Oshrlimm n) (e1:::Enil) + | _ => + Eop (Oshrlimm n) (e1:::Enil) + end. + +(** ** General shifts *) + +Definition shll (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shll e1 e2 else + match is_intconst e2 with + | Some n2 => shllimm e1 n2 + | None => Eop Oshll (e1:::e2:::Enil) + end. + +Definition shrl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrl e1 e2 else + match is_intconst e2 with + | Some n2 => shrlimm e1 n2 + | None => Eop Oshrl (e1:::e2:::Enil) + end. + +Definition shrlu (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.shrlu e1 e2 else + match is_intconst e2 with + | Some n2 => shrluimm e1 n2 + | _ => Eop Oshrlu (e1:::e2:::Enil) + end. + +(** ** Integer multiply *) + +Definition mullimm_base (n1: int64) (e2: expr) := + match Int64.one_bits' n1 with + | i :: nil => + shllimm e2 i + | i :: j :: nil => + Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) + | _ => + Eop (Omullimm n1) (e2 ::: Enil) + end. + +Nondetfunction mullimm (n1: int64) (e2: expr) := + if Archi.splitlong then SplitLong.mullimm n1 e2 + else if Int64.eq n1 Int64.zero then longconst Int64.zero + else if Int64.eq n1 Int64.one then e2 + else match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) + | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) + | _ => mullimm_base n1 e2 + end. + +Nondetfunction mull (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.mull e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 + | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 + | _, _ => Eop Omull (e1:::e2:::Enil) + end. + +Definition mullhu (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhu e1 n2 else + Eop Omullhu (e1 ::: longconst n2 ::: Enil). + +Definition mullhs (e1: expr) (n2: int64) := + if Archi.splitlong then SplitLong.mullhs e1 n2 else + Eop Omullhs (e1 ::: longconst n2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then longconst Int64.zero else + if Int64.eq n1 Int64.mone then e2 else + match e2 with + | Eop (Olongconst n2) Enil => + longconst (Int64.and n1 n2) + | Eop (Oandlimm n2) (t2:::Enil) => + Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) + | Eop Onotl (t2:::Enil) => Eop (Oandnlimm n1) (t2:::Enil) + | _ => + Eop (Oandlimm n1) (e2:::Enil) + end. + +Nondetfunction andl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.andl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 + | (Eop Onotl (t1:::Enil)), t2 => Eop Oandnl (t1:::t2:::Enil) + | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) + | _, _ => Eop Oandl (e1:::e2:::Enil) + end. + +Nondetfunction orlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone then longconst Int64.mone else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) + | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) + | Eop Onotl (t2:::Enil) => Eop (Oornlimm n1) (t2:::Enil) + | _ => Eop (Oorlimm n1) (e2:::Enil) + end. + +Nondetfunction orl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.orl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 + | (Eop Onotl (t1:::Enil)), t2 => Eop Oornl (t1:::t2:::Enil) + | t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil) + | (Eop (Oandlimm nmask) (prev:::Enil)), + (Eop (Oandlimm mask) + ((Eop (Oshllimm start) (fld:::Enil)):::Enil)) => + let zstart := Int.unsigned start in + let zstop := int64_highest_bit mask in + if is_bitfieldl zstop zstart + then + let mask' := Int64.repr (zbitfield_mask zstop zstart) in + if and_dec (Int64.eq_dec mask mask') + (Int64.eq_dec nmask (Int64.not mask')) + then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) + else Eop Oorl (e1:::e2:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | (Eop (Oandlimm nmask) (prev:::Enil)), + (Eop (Oandlimm mask) (fld:::Enil)) => + let zstart := 0 in + let zstop := int64_highest_bit mask in + if is_bitfieldl zstop zstart + then + let mask' := Int64.repr (zbitfield_mask zstop zstart) in + if and_dec (Int64.eq_dec mask mask') + (Int64.eq_dec nmask (Int64.not mask')) + then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) + else Eop Oorl (e1:::e2:::Enil) + else Eop Oorl (e1:::e2:::Enil) + | _, _ => Eop Oorl (e1:::e2:::Enil) + end. + +Nondetfunction xorlimm (n1: int64) (e2: expr) := + if Int64.eq n1 Int64.zero then e2 else + if Int64.eq n1 Int64.mone + then Eop Onotl (e2:::Enil) + else + match e2 with + | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) + | Eop (Oxorlimm n2) (t2:::Enil) => + let n := Int64.xor n1 n2 in + if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) + | _ => Eop (Oxorlimm n1) (e2:::Enil) + end. + +Nondetfunction xorl (e1: expr) (e2: expr) := + if Archi.splitlong then SplitLong.xorl e1 e2 else + match e1, e2 with + | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 + | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 + | _, _ => Eop Oxorl (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Nondetfunction notl (e: expr) := + match e with + | Eop Oandl (e1:::e2:::Enil) => Eop Onandl (e1:::e2:::Enil) + | Eop (Oandlimm n) (e1:::Enil) => Eop (Onandlimm n) (e1:::Enil) + | Eop Oorl (e1:::e2:::Enil) => Eop Onorl (e1:::e2:::Enil) + | Eop (Oorlimm n) (e1:::Enil) => Eop (Onorlimm n) (e1:::Enil) + | Eop Oxorl (e1:::e2:::Enil) => Eop Onxorl (e1:::e2:::Enil) + | Eop (Oxorlimm n) (e1:::Enil) => Eop (Onxorlimm n) (e1:::Enil) + | Eop Onandl (e1:::e2:::Enil) => Eop Oandl (e1:::e2:::Enil) + | Eop (Onandlimm n) (e1:::Enil) => Eop (Oandlimm n) (e1:::Enil) + | Eop Onorl (e1:::e2:::Enil) => Eop Oorl (e1:::e2:::Enil) + | Eop (Onorlimm n) (e1:::Enil) => Eop (Oorlimm n) (e1:::Enil) + | Eop Onxorl (e1:::e2:::Enil) => Eop Oxorl (e1:::e2:::Enil) + | Eop (Onxorlimm n) (e1:::Enil) => Eop (Oxorlimm n) (e1:::Enil) + | Eop Oandnl (e1:::e2:::Enil) => Eop Oornl (e2:::e1:::Enil) + | Eop (Oandnlimm n) (e1:::Enil) => Eop (Oorlimm (Int64.not n)) (e1:::Enil) + | Eop Oornl (e1:::e2:::Enil) => Eop Oandnl (e2:::e1:::Enil) + | Eop (Oornlimm n) (e1:::Enil) => Eop (Oandlimm (Int64.not n)) (e1:::Enil) + | Eop Onotl (e1:::Enil) => e1 + | Eop (Olongconst k) Enil => Eop (Olongconst (Int64.not k)) Enil + | _ => Eop Onotl (e:::Enil) + end. +(* old: if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. *) + +(** ** Integer division and modulus *) + +Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. +Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. +Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. +Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. + +Definition shrxlimm (e: expr) (n: int) := + if Archi.splitlong then SplitLong.shrxlimm e n else + if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). + +(** ** Comparisons *) + +Definition cmplu (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmplu c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) + end. + +Definition cmpl (c: comparison) (e1 e2: expr) := + if Archi.splitlong then SplitLong.cmpl c e1 e2 else + match is_longconst e1, is_longconst e2 with + | Some n1, Some n2 => + Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil + | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) + | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) + | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) + end. + +(** ** Floating-point conversions *) + +Definition longoffloat (e: expr) := + if Archi.splitlong then SplitLong.longoffloat e else + Eop Olongoffloat (e:::Enil). + +Definition longuoffloat (e: expr) := + if Archi.splitlong then SplitLong.longuoffloat e else + Eop Olonguoffloat (e:::Enil). + +Definition floatoflong (e: expr) := + if Archi.splitlong then SplitLong.floatoflong e else + Eop Ofloatoflong (e:::Enil). + +Definition floatoflongu (e: expr) := + if Archi.splitlong then SplitLong.floatoflongu e else + Eop Ofloatoflongu (e:::Enil). + +Definition longofsingle (e: expr) := longoffloat (floatofsingle e). + +Definition longuofsingle (e: expr) := longuoffloat (floatofsingle e). + +Definition singleoflong (e: expr) := SplitLong.singleoflong e. + +Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. + +End SELECT. + +(* Local Variables: *) +(* mode: coq *) +(* End: *) diff --git a/kvx/SelectLongproof.v b/kvx/SelectLongproof.v new file mode 100644 index 00000000..fb38bbce --- /dev/null +++ b/kvx/SelectLongproof.v @@ -0,0 +1,950 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Correctness of instruction selection for 64-bit integer operations *) + +Require Import String Coqlib Maps Integers Floats Errors. +Require Archi. +Require Import AST Values ExtValues Memory Globalenvs Events. +Require Import Cminor Op CminorSel. +Require Import OpHelpers OpHelpersproof. +Require Import SelectOp SelectOpproof SplitLong SplitLongproof. +Require Import SelectLong. +Require Import DecBoolOps. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + +(** * Correctness of the instruction selection functions for 64-bit operators *) + +Section CMCONSTR. + +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. +Variable sp: val. +Variable e: env. +Variable m: mem. + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := + forall le a x y, + eval_expr ge sp e m le a x -> + sem x = Some y -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. + +Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := + forall le a x b y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + sem x y = Some z -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. + +Theorem eval_longconst: + forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). +Proof. + unfold longconst; intros; destruct Archi.splitlong. + apply SplitLongproof.eval_longconst. + EvalOp. +Qed. + +Lemma is_longconst_sound: + forall v a n le, + is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. +Proof with (try discriminate). + intros. unfold is_longconst in *. destruct Archi.splitlong. + eapply SplitLongproof.is_longconst_sound; eauto. + assert (a = Eop (Olongconst n) Enil). + { destruct a... destruct o... destruct e0... congruence. } + subst a. InvEval. auto. +Qed. + +Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. +Proof. + unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. +- TrivialExists. +Qed. + +Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. +Proof. + unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. +Proof. + unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. + red; intros. destruct (is_intconst a) as [n|] eqn:C. +- econstructor; split. apply eval_longconst. + exploit is_intconst_sound; eauto. intros; subst x. auto. +- TrivialExists. +Qed. + +Theorem eval_negl: unary_constructor_sound negl Val.negl. +Proof. + unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. + red; intros. destruct (is_longconst a) as [n|] eqn:C. +- exploit is_longconst_sound; eauto. intros EQ; subst x. + econstructor; split. apply eval_longconst. auto. +- TrivialExists. +Qed. + + +Theorem eval_addlimm_shllimm: + forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)). +Proof. + red; unfold addlimm_shllimm; intros. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } + { unfold addxl. rewrite Val.addl_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } +Qed. + +Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). +Proof. + unfold addlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + subst. exists x; split; auto. + destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. + destruct (addlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. +- destruct (Compopts.optim_globaladdroffset _). + + econstructor; split. EvalOp. simpl; eauto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. + destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto. + + TrivialExists. repeat econstructor. simpl. trivial. +- econstructor; split. EvalOp. simpl; eauto. + destruct sp; simpl; auto. destruct Archi.ptr64; auto. + rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. +- subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. +- TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int64.add_assoc. rewrite Int64.add_commut. + reflexivity. +- pose proof eval_addlimm_shllimm as ADDXL. + unfold unary_constructor_sound in ADDXL. + unfold addxl in ADDXL. + rewrite Val.addl_commut. + subst x. + apply ADDXL; assumption. +- TrivialExists. +Qed. + +Lemma eval_addxl: forall n, binary_constructor_sound (addl_shllimm n) (ExtValues.addxl n). +Proof. + red. + intros. + unfold addl_shllimm. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + (* Oaddxl *) + - TrivialExists; + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } +Qed. + +Theorem eval_addl: binary_constructor_sound addl Val.addl. +Proof. + unfold addl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. +(* + assert (SF: Archi.ptr64 = true). + { Local Transparent Archi.splitlong. unfold Archi.splitlong in SL. + destruct Archi.ptr64; simpl in *; congruence. } +*) +(* + assert (B: forall id ofs n, + Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = + Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))). + { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs. + apply Genv.shift_symbol_address_64; auto. } + +*) + red; intros until y. + case (addl_match a b); intros; InvEval. + - rewrite Val.addl_commut. apply eval_addlimm; auto. + - apply eval_addlimm; auto. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) (Val.addl v0 (Vlong n2))) + with (Val.addl (Val.addl v1 v0) (Val.addl (Vlong n1) (Vlong n2))). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.addl_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. + rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + destruct Archi.ptr64 eqn:SF; auto. + apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. + rewrite Ptrofs.add_commut. auto with ptrofs. + - subst. + replace (Val.addl (Val.addl v1 (Vlong n1)) y) + with (Val.addl (Val.addl v1 y) (Vlong n1)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. decEq. apply Val.addl_commut. + - subst. + replace (Val.addl x (Val.addl v1 (Vlong n2))) + with (Val.addl (Val.addl x v1) (Vlong n2)). + apply eval_addlimm. EvalOp. + repeat rewrite Val.addl_assoc. reflexivity. + - subst. TrivialExists. + - subst. rewrite Val.addl_commut. TrivialExists. + - subst. TrivialExists. + - subst. rewrite Val.addl_commut. TrivialExists. + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + rewrite Val.addl_commut. + apply ADDXL; assumption. + (* Oaddxl *) + - subst. pose proof eval_addxl as ADDXL. + unfold binary_constructor_sound in ADDXL. + apply ADDXL; assumption. + - TrivialExists. +Qed. + +Theorem eval_subl: binary_constructor_sound subl Val.subl. +Proof. + unfold subl. destruct Archi.splitlong eqn:SL. + apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. + red; intros; destruct (subl_match a b); InvEval. +- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. +- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. + rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp. + apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. +- subst. rewrite Val.subl_addl_r. + apply eval_addlimm; EvalOp. +- TrivialExists. simpl. subst. reflexivity. +- TrivialExists. simpl. subst. + destruct v1; destruct x; simpl; trivial. + + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Int64.sub_add_opp. + reflexivity. + + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. + f_equal. f_equal. + rewrite <- Int64.neg_mul_distr_r. + rewrite Ptrofs.sub_add_opp. + unfold Ptrofs.add. + f_equal. f_equal. + rewrite (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 (Int64.mul i n)) (Int64.mul i n)). + rewrite (Ptrofs.agree64_of_int ARCHI64 (Int64.neg (Int64.mul i n))). + reflexivity. + apply (Ptrofs.agree64_of_int ARCHI64). +- TrivialExists. +Qed. + +Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). +Proof. + intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. + destruct (shllimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). +Proof. + intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. + destruct (shrluimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. +- subst x. + simpl negb. + cbn iota. + destruct (is_bitfieldl _ _) eqn:BOUNDS. + + exists (extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold extfzl. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int64.zwordsize + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int64.zwordsize + (Z.sub + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. + simpl. + destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. + destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + constructor. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). +Proof. + intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto. + red; intros. + predSpec Int.eq Int.eq_spec n Int.zero. + exists x; split; auto. subst n; destruct x; simpl; auto. + destruct (Int.ltu Int.zero Int64.iwordsize'); auto. + change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. + destruct (Int.ltu n Int64.iwordsize') eqn:LT. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v + /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. + destruct (shrlimm_match a); InvEval. +- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. +- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. + subst. econstructor; split. EvalOp. simpl; eauto. + destruct v1; simpl; auto. rewrite LT'. + destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. + simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. +- subst x. + simpl negb. + cbn iota. + destruct (is_bitfieldl _ _) eqn:BOUNDS. + + exists (extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold extfsl. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int64.zwordsize + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int64.zwordsize + (Z.sub + (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. + simpl. + destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. + destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + constructor. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. +- apply DEFAULT. +- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. +Qed. + +Theorem eval_shll: binary_constructor_sound shll Val.shll. +Proof. + unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. +Proof. + unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto. +- TrivialExists. +Qed. + +Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. +Proof. + unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto. + red; intros. destruct (is_intconst b) as [n2|] eqn:C. +- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). +Proof. + intros; unfold mullimm_base. red; intros. + assert (DEFAULT: exists v, + eval_expr ge sp e m le (Eop Omull (a ::: longconst n ::: Enil)) v + /\ Val.lessdef (Val.mull x (Vlong n)) v). + { econstructor; split. EvalOp. constructor. eauto. constructor. apply eval_longconst. constructor. simpl; eauto. + auto. } + generalize (Int64.one_bits'_decomp n); intros D. + destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. +- TrivialExists. +- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). + apply eval_shllimm; auto. + simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. + rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib). + rewrite Int64.shl'_mul; auto. +- set (le' := x :: le). + assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity). + exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1). + exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2). + exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3). + exists v3; split. econstructor; eauto. + rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto. + simpl in *. + rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib). + rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). + inv B1; inv B2. simpl in B3; inv B3. + rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. +- TrivialExists. +Qed. + +Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). +Proof. + unfold mullimm. intros; red; intros. + destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_mullimm; eauto. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.one. + exists x; split; auto. + destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto. + destruct (mullimm_match a); InvEval. +- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto. +- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2). + exploit (eval_addlimm (Int64.mul n n2)). eexact A2. intros (v3 & A3 & B3). + exists v3; split; auto. + subst x. destruct v1; simpl; auto. + simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. + rewrite (Int64.mul_commut n). auto. +- apply eval_mullimm_base; auto. +Qed. + +Theorem eval_mull: binary_constructor_sound mull Val.mull. +Proof. + unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto. + red; intros; destruct (mull_match a b); InvEval. +- rewrite Val.mull_commut. apply eval_mullimm; auto. +- apply eval_mullimm; auto. +- TrivialExists. +Qed. + +Theorem eval_mullhu: + forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). +Proof. + unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_mullhs: + forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). +Proof. + unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto. + red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. +Qed. + +Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). +Proof. + unfold andlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists (Vlong Int64.zero); split. apply eval_longconst. + subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + exists x; split. assumption. + subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. + destruct (andlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. +- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. +- TrivialExists. +- TrivialExists. +Qed. + +Lemma int64_eq_commut: forall x y : int64, + (Int64.eq x y) = (Int64.eq y x). +Proof. + intros. + predSpec Int64.eq Int64.eq_spec x y; + predSpec Int64.eq Int64.eq_spec y x; + congruence. +Qed. + +Theorem eval_andl: binary_constructor_sound andl Val.andl. +Proof. + unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. + red; intros. destruct (andl_match a b). +- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. +- InvEval. apply eval_andlimm; auto. +- (*andn*) InvEval. TrivialExists. simpl. congruence. +- (*andn reverse*) InvEval. rewrite Val.andl_commut. TrivialExists; simpl. congruence. + (* +- (* selectl *) + InvEval. + predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; TrivialExists. + + constructor. econstructor; constructor. + constructor; try constructor; try constructor; try eassumption. + + simpl in *. f_equal. inv H6. + unfold selectl. + simpl. + destruct v3; simpl; trivial. + rewrite int64_eq_commut. + destruct (Int64.eq i Int64.zero); simpl. + * replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. + destruct y; simpl; trivial. + * replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. + destruct y; simpl; trivial. + rewrite Int64.and_commut. rewrite Int64.and_mone. reflexivity. + + constructor. econstructor. constructor. econstructor. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. eassumption. constructor. + + simpl in *. congruence. *) +- TrivialExists. +Qed. + +Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). +Proof. + unfold orlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. + predSpec Int64.eq Int64.eq_spec n Int64.mone. + econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. + destruct (orlimm_match a); InvEval; subst. +- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. +- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. +- InvEval. TrivialExists. +- TrivialExists. +Qed. + + +Theorem eval_orl: binary_constructor_sound orl Val.orl. +Proof. + unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. + red; intros. + destruct (orl_match a b). +- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. +- InvEval. apply eval_orlimm; auto. +- (*orn*) InvEval. TrivialExists; simpl; congruence. +- (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence. + + - (*insfl first case*) + destruct (is_bitfieldl _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * rewrite Rnmask in *. + inv H. inv H0. inv H4. inv H3. inv H9. inv H8. + simpl in H6, H7. + inv H6. inv H7. + inv H4. inv H3. inv H7. + simpl in H6. + inv H6. + set (zstop := (int64_highest_bit mask)) in *. + set (zstart := (Int.unsigned start)) in *. + + TrivialExists. + simpl. f_equal. + + unfold insfl. + rewrite Risbitfield. + rewrite Rmask. + simpl. + unfold bitfield_maskl. + subst zstart. + rewrite Int.repr_unsigned. + reflexivity. + * TrivialExists. + + TrivialExists. + - destruct (is_bitfieldl _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * rewrite Rnmask in *. + inv H. inv H0. inv H4. inv H6. inv H8. inv H3. inv H8. + inv H0. simpl in H7. inv H7. + set (zstop := (int64_highest_bit mask)) in *. + set (zstart := 0) in *. + + TrivialExists. simpl. f_equal. + unfold insfl. + rewrite Risbitfield. + rewrite Rmask. + simpl. + subst zstart. + f_equal. + destruct v0; simpl; trivial. + unfold Int.ltu, Int64.iwordsize', Int64.zwordsize, Int64.wordsize. + rewrite Int.unsigned_repr. + ** rewrite Int.unsigned_repr. + *** simpl. + rewrite Int64.shl'_zero. + reflexivity. + *** simpl. unfold Int.max_unsigned. unfold Int.modulus. + simpl. omega. + ** unfold Int.max_unsigned. unfold Int.modulus. + simpl. omega. + * TrivialExists. + + TrivialExists. +- TrivialExists. +Qed. + +Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). +Proof. + unfold xorlimm; intros; red; intros. + predSpec Int64.eq Int64.eq_spec n Int64.zero. + - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. + - predSpec Int64.eq Int64.eq_spec n Int64.mone. + -- subst n. intros. rewrite <- Val.notl_xorl. TrivialExists. + -- destruct (xorlimm_match a); InvEval; subst. + + econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. + + rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). + predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. + * rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. + * TrivialExists. + + TrivialExists. +Qed. + +Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. +Proof. + unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. + red; intros. destruct (xorl_match a b). +- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. +- InvEval. apply eval_xorlimm; auto. +- TrivialExists. +Qed. + +Theorem eval_notl: unary_constructor_sound notl Val.notl. +Proof. + assert (forall v, Val.lessdef (Val.notl (Val.notl v)) v). + destruct v; simpl; auto. rewrite Int64.not_involutive; auto. + unfold notl; red; intros until x; case (notl_match a); intros; InvEval. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - subst x. exists (Val.andl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.andl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.orl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.orl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.xorl v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.xorl v1 (Vlong n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + (* andn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_and_or_not. + rewrite Int64.not_involutive. + apply Int64.or_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_and_or_not. + rewrite Int64.not_involutive. + reflexivity. + (* orn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_or_and_not. + rewrite Int64.not_involutive. + apply Int64.and_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int64.not_or_and_not. + rewrite Int64.not_involutive. + reflexivity. + - subst x. exists v1; split; trivial. + - TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. +Proof. + unfold divls_base; red; intros. + eapply SplitLongproof.eval_divls_base; eauto. +Qed. + +Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. +Proof. + unfold modls_base; red; intros. + eapply SplitLongproof.eval_modls_base; eauto. +Qed. + +Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. +Proof. + unfold divlu_base; red; intros. + eapply SplitLongproof.eval_divlu_base; eauto. +Qed. + +Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. +Proof. + unfold modlu_base; red; intros. + eapply SplitLongproof.eval_modlu_base; eauto. +Qed. + +Theorem eval_shrxlimm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrxl x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. +Proof. + unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. ++ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. ++ predSpec Int.eq Int.eq_spec n Int.zero. +- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. + change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. +- TrivialExists. simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_cmplu: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmplu (Mem.valid_pointer m) c x y = Some v -> + eval_expr ge sp e m le (cmplu c a b) v. +Proof. + unfold cmplu; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32. + unfold Val.cmplu in H1. + destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_cmpl: + forall c le a x b y v, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.cmpl c x y = Some v -> + eval_expr ge sp e m le (cmpl c a b) v. +Proof. + unfold cmpl; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_cmpl; eauto. + unfold Val.cmpl in H1. + destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1. + destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; + try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); + try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); + subst. +- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity. +- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +- EvalOp. simpl; rewrite C; auto. +Qed. + +Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. +Proof. + unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longoffloat; eauto. + TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. +Proof. + unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_longuoffloat; eauto. + TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. +Proof. + unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflong; eauto. + TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. +Proof. + unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. + eapply SplitLongproof.eval_floatoflongu; eauto. + TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. +Proof. + unfold longofsingle; red; intros. + destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2. + exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. + apply Float32.to_long_double in EQ. + eapply eval_longoffloat; eauto. simpl. + change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. +Qed. + +Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. +Proof. + unfold longuofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) + destruct x; simpl in H0; inv H0. destruct (Float32.to_longu f) as [n|] eqn:EQ; simpl in H2; inv H2. + exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. + apply Float32.to_longu_double in EQ. + eapply eval_longuoffloat; eauto. simpl. + change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. +Qed. + +Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. +Proof. + unfold singleoflong; red; intros. (* destruct Archi.splitlong eqn:SL. *) + eapply SplitLongproof.eval_singleoflong; eauto. +(* TrivialExists. *) +Qed. + +Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. +Proof. + unfold singleoflongu; red; intros. (* destruct Archi.splitlong eqn:SL. *) + eapply SplitLongproof.eval_singleoflongu; eauto. +(* TrivialExists. *) +Qed. + +End CMCONSTR. diff --git a/kvx/SelectOp.vp b/kvx/SelectOp.vp new file mode 100644 index 00000000..9e5d45a0 --- /dev/null +++ b/kvx/SelectOp.vp @@ -0,0 +1,715 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + + +(** Instruction selection for operators *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + This file defines functions for building CminorSel expressions and + statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. + + On top of the "smart constructor" functions defined below, + module [Selection] implements the actual instruction selection pass. +*) + +Require Archi. +Require Import Coqlib. +Require Import Compopts. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Op. +Require Import CminorSel. +Require Import OpHelpers. +Require Import ExtValues ExtFloats. +Require Import DecBoolOps. +Require Import Chunks. +Require Import Builtins. +Require Compopts. + +Local Open Scope cminorsel_scope. + +Local Open Scope string_scope. +Local Open Scope error_monad_scope. + +Section SELECT. + +Context {hf: helper_functions}. + +Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := + match cond, args with + | (Ccompimm c x), (e1 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccomp0 c), e1) + else None + + | (Ccompuimm c x), (e1 ::: Enil) => + if Int.eq_dec x Int.zero + then Some ((Ccompu0 c), e1) + else None + + | (Ccomplimm c x), (e1 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccompl0 c), e1) + else None + + | (Ccompluimm c x), (e1 ::: Enil) => + if Int64.eq_dec x Int64.zero + then Some ((Ccomplu0 c), e1) + else None + + | _, _ => None + end. + +(** Ternary operator *) +Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) := + match ty, cond0, e1, e2, e3 with + | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 => + (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tint, cond0, (Eop (Ointconst imm) Enil), e2, e3 => + (Eop (Oselimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) + | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => + (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil)) + | Tlong, cond0, (Eop (Olongconst imm) Enil), e2, e3 => + (Eop (Osellimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) + | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil)) + end. + +Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := + Some( + match cond_to_condition0 cond args with + | None => select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args) + | Some(cond0, ec) => select0 ty cond0 e1 e2 ec + end). + + +(** ** Constants **) + +Definition addrsymbol (id: ident) (ofs: ptrofs) := + Eop (Oaddrsymbol id ofs) Enil. + +Definition addrstack (ofs: ptrofs) := + Eop (Oaddrstack ofs) Enil. + +(** ** Integer addition and pointer addition *) + +Definition addimm_shlimm sh k2 e1 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned sh) with + | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) + | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) + end + else Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil). + +Nondetfunction addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | Eop (Oaddximm sh m) (t ::: Enil) => Eop (Oaddximm sh (Int.add n m)) (t ::: Enil) + | Eop (Oshlimm sh) (t1:::Enil) => addimm_shlimm sh n t1 + | _ => Eop (Oaddimm n) (e ::: Enil) + end. + +Definition add_shlimm n e1 e2 := + if Compopts.optim_addx tt + then + match shift1_4_of_z (Int.unsigned n) with + | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) + | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) + end + else Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil). + +Nondetfunction add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) + | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => + Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + if Compopts.optim_madd tt + then Eop Omadd (t1:::t2:::t3:::Enil) + else Eop Oadd (e1:::e2:::Enil) + | (Eop Omul (t2:::t3:::Enil)), t1 => + if Compopts.optim_madd tt + then Eop Omadd (t1:::t2:::t3:::Enil) + else Eop Oadd (e1:::e2:::Enil) + | t1, (Eop (Omulimm n) (t2:::Enil)) => + if Compopts.optim_madd tt + then Eop (Omaddimm n) (t1:::t2:::Enil) + else Eop Oadd (e1:::e2:::Enil) + | (Eop (Omulimm n) (t2:::Enil)), t1 => + if Compopts.optim_madd tt + then Eop (Omaddimm n) (t1:::t2:::Enil) + else Eop Oadd (e1:::e2:::Enil) + | (Eop (Oshlimm n) (t1:::Enil)), t2 => + add_shlimm n t1 t2 + | t2, (Eop (Oshlimm n) (t1:::Enil)) => + add_shlimm n t1 t2 + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +Nondetfunction sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => + addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | t1, (Eop Omul (t2:::t3:::Enil)) => + Eop Omsub (t1:::t2:::t3:::Enil) + | t1, (Eop (Omulimm n) (t2:::Enil)) => + if Compopts.optim_madd tt + then Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) + else Eop Osub (e1:::e2:::Enil) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. + +Nondetfunction negint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil + | _ => Eop Oneg (e ::: Enil) + end. + +(** ** Immediate shifts *) + +Nondetfunction shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shl n1 n)) Enil + | Eop (Oshlimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshlimm n) (e1:::Enil) + | _ => + Eop (Oshlimm n) (e1:::Enil) + end. + +Nondetfunction shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shru n1 n)) Enil + | Eop (Oshruimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | Eop (Oshlimm n1) (t1:::Enil) => + let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in + if is_bitfield stop start + then Eop (Oextfz stop start) (t1:::Enil) + else Eop (Oshruimm n) (e1:::Enil) + | _ => + Eop (Oshruimm n) (e1:::Enil) + end. + +Nondetfunction shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then + e1 + else if negb (Int.ltu n Int.iwordsize) then + Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + else match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst (Int.shr n1 n)) Enil + | Eop (Oshrimm n1) (t1:::Enil) => + if Int.ltu (Int.add n n1) Int.iwordsize + then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | Eop (Oshlimm n1) (t1:::Enil) => + let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in + let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in + if is_bitfield stop start + then Eop (Oextfs stop start) (t1:::Enil) + else Eop (Oshrimm n) (e1:::Enil) + | _ => + Eop (Oshrimm n) (e1:::Enil) + end. + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop (Omulimm n1) (e2 ::: Enil) + end. + +Nondetfunction mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.one then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. + +Nondetfunction mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. + +Definition mulhs (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrlimm (Int.repr 32)) + (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: + Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhs (e1 ::: e2 ::: Enil). + +Definition mulhu (e1: expr) (e2: expr) := + if Archi.ptr64 then + Eop Olowlong + (Eop (Oshrluimm (Int.repr 32)) + (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: + Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) + ::: Enil) + else + Eop Omulhu (e1 ::: e2 ::: Enil). + +(** ** Bitwise and, or, xor *) + +Nondetfunction andimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil + else if Int.eq n1 Int.mone then e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil + | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oandnimm n1) (t2:::Enil) + | _ => Eop (Oandimm n1) (e2:::Enil) + end. + +Nondetfunction and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 + | t1, Eop (Ointconst n2) Enil => andimm n2 t1 + | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) + | t1, (Eop Onot (t2:::Enil)) => Eop Oandn (t2:::t1:::Enil) + | _, _ => Eop Oand (e1:::e2:::Enil) + end. + +Nondetfunction orimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then e2 + else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil + | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) + | Eop Onot (t2:::Enil) => Eop (Oornimm n1) (t2:::Enil) + | _ => Eop (Oorimm n1) (e2:::Enil) + end. + +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + +Nondetfunction or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 + | t1, Eop (Ointconst n2) Enil => orimm n2 t1 + | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => + if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 + then Eop (Ororimm n2) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) + | t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil) + | (Eop (Oandimm nmask) (prev:::Enil)), + (Eop (Oandimm mask) + ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => + let zstart := Int.unsigned start in + let zstop := int_highest_bit mask in + if is_bitfield zstop zstart + then + let mask' := Int.repr (zbitfield_mask zstop zstart) in + if and_dec (Int.eq_dec mask mask') + (Int.eq_dec nmask (Int.not mask')) + then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) + else Eop Oor (e1:::e2:::Enil) + else Eop Oor (e1:::e2:::Enil) + | (Eop (Oandimm nmask) (prev:::Enil)), + (Eop (Oandimm mask) (fld:::Enil)) => + let zstart := 0 in + let zstop := int_highest_bit mask in + if is_bitfield zstop zstart + then + let mask' := Int.repr (zbitfield_mask zstop zstart) in + if and_dec (Int.eq_dec mask mask') + (Int.eq_dec nmask (Int.not mask')) + then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) + else Eop Oor (e1:::e2:::Enil) + else Eop Oor (e1:::e2:::Enil) + | _, _ => Eop Oor (e1:::e2:::Enil) + end. + +Nondetfunction xorimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero + then e2 + else + if Int.eq n1 Int.mone + then Eop Onot (e2:::Enil) + else + match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil + | Eop (Oxorimm n2) (t2:::Enil) => + let n := Int.xor n1 n2 in + if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) + | _ => Eop (Oxorimm n1) (e2:::Enil) + end. + +Nondetfunction xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 + | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. + +(** ** Integer logical negation *) + +Nondetfunction notint (e: expr) := + match e with + | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) + | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) + | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) + | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) + | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) + | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) + | Eop Onand (e1:::e2:::Enil) => Eop Oand (e1:::e2:::Enil) + | Eop (Onandimm n) (e1:::Enil) => Eop (Oandimm n) (e1:::Enil) + | Eop Onor (e1:::e2:::Enil) => Eop Oor (e1:::e2:::Enil) + | Eop (Onorimm n) (e1:::Enil) => Eop (Oorimm n) (e1:::Enil) + | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) + | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) + | Eop Oandn (e1:::e2:::Enil) => Eop Oorn (e2:::e1:::Enil) + | Eop (Oandnimm n) (e1:::Enil) => Eop (Oorimm (Int.not n)) (e1:::Enil) + | Eop Oorn (e1:::e2:::Enil) => Eop Oandn (e2:::e1:::Enil) + | Eop (Oornimm n) (e1:::Enil) => Eop (Oandimm (Int.not n)) (e1:::Enil) + | Eop Onot (e1:::Enil) => e1 + | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil + | _ => Eop Onot (e:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition divs_base (e1: expr) (e2: expr) := + Eexternal i32_sdiv sig_ii_i (e1 ::: e2 ::: Enil). + +Definition mods_base (e1: expr) (e2: expr) := + Eexternal i32_smod sig_ii_i (e1 ::: e2 ::: Enil). + +Definition divu_base (e1: expr) (e2: expr) := + Eexternal i32_udiv sig_ii_i (e1 ::: e2 ::: Enil). + +Definition modu_base (e1: expr) (e2: expr) := + Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). + +(* Alternate definition, not convenient for strength reduction during constant propagation *) +(* +(* n2 will be less than 31. *) + +Definition shrximm_inner (e1: expr) (n2: int) := + Eop (Oshruimm (Int.sub Int.iwordsize n2)) + ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) + (e1 ::: Enil)) + ::: Enil). + +Definition shrximm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then e1 + else Eop (Oshrimm n2) + ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) + ::: Enil). +*) + +(** ** General shifts *) + +Nondetfunction shl (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shlimm e1 n2 + | _ => Eop Oshl (e1:::e2:::Enil) + end. + +Nondetfunction shr (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shrimm e1 n2 + | _ => Eop Oshr (e1:::e2:::Enil) + end. + +Nondetfunction shru (e1: expr) (e2: expr) := + match e2 with + | Eop (Ointconst n2) Enil => shruimm e1 n2 + | _ => Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +Definition negf (e: expr) := Eop Onegf (e ::: Enil). +Definition absf (e: expr) := Eop Oabsf (e ::: Enil). +Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). +Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). +Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). + +Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). +Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). +Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). +Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). +Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). + +(** ** Comparisons *) + +Nondetfunction compimm (default: comparison -> int -> condition) + (sem: comparison -> int -> int -> bool) + (c: comparison) (e1: expr) (n2: int) := + match c, e1 with + | c, Eop (Ointconst n1) Enil => + Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil + | Ceq, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp (negate_condition c)) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp c) el + else + Eop (Ointconst Int.zero) Enil + | Cne, Eop (Ocmp c) el => + if Int.eq_dec n2 Int.zero then + Eop (Ocmp c) el + else if Int.eq_dec n2 Int.one then + Eop (Ocmp (negate_condition c)) el + else + Eop (Ointconst Int.one) Enil + | _, _ => + Eop (Ocmp (default c n2)) (e1 ::: Enil) + end. + +Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompimm Int.cmp c t1 n2 + | _, _ => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => + compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 + | t1, Eop (Ointconst n2) Enil => + compimm Ccompuimm Int.cmpu c t1 n2 + | _, _ => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +Definition compfs (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). + +(** ** Integer conversions *) + +Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. + +Nondetfunction cast8signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil + | _ => Eop Ocast8signed (e ::: Enil) + end. + +Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. + +Nondetfunction cast16signed (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil + | _ => Eop Ocast16signed (e ::: Enil) + end. + +(** ** Floating-point conversions *) + +Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). +Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). + +Nondetfunction floatofintu (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil + | _ => Eop Ofloatoflongu ((Eop Ocast32unsigned (e ::: Enil)) ::: Enil) + end. + +Nondetfunction floatofint (e: expr) := + match e with + | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil + | _ => Eop Ofloatoflong ((Eop Ocast32signed (e ::: Enil)) ::: Enil) + end. + +Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). +Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). + +Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). +Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). + +Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). +Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). + +(** ** Recognition of addressing modes for load and store operations *) + +Nondetfunction addressing (chunk: memory_chunk) (e: expr) := + match e with + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddrsymbol id ofs) Enil => + (if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) + then (Aindexed Ptrofs.zero, e:::Enil) + else (Aglobal id ofs, Enil)) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) + | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) + | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => + (if Compopts.optim_xsaddr tt + then let zscale := Int.unsigned scale in + if Z.eq_dec zscale (zscale_of_chunk chunk) + then (Aindexed2XS zscale, e1:::e2:::Enil) + else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) + else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)) + | Eop (Oaddxl sh) (e1:::e2:::Enil) => + let zscale := ExtValues.z_of_shift1_4 sh in + let scale := Int.repr zscale in + (if Compopts.optim_xsaddr tt + then if Z.eq_dec zscale (zscale_of_chunk chunk) + then (Aindexed2XS zscale, e2:::e1:::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil) + else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil)) + | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Ptrofs.zero, e:::Enil) + end. + +(** ** Arguments of builtins *) + +Nondetfunction builtin_arg (e: expr) := + match e with + | Eop (Ointconst n) Enil => BA_int n + | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs + | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs + | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => + BA_long (Int64.ofwords h l) + | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) + | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs + | Eop (Oaddimm n) (e1:::Enil) => + if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) + | Eop (Oaddlimm n) (e1:::Enil) => + if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e + | _ => BA e + end. + +(* float division *) + +Definition divf_base (e1: expr) (e2: expr) := + (* Eop Odivf (e1 ::: e2 ::: Enil). *) + Eexternal f64_div sig_ff_f (e1 ::: e2 ::: Enil). + +Definition divfs_base1 (e2 : expr) := + Eop Oinvfs (e2 ::: Enil). +Definition divfs_baseX (e1 : expr) (e2 : expr) := + (* Eop Odivf (e1 ::: e2 ::: Enil). *) + Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). + +Nondetfunction divfs_base (e1: expr) := + match e1 with + | Eop (Osingleconst f) Enil => + (if Float32.eq_dec f ExtFloat32.one + then divfs_base1 + else divfs_baseX e1) + | _ => divfs_baseX e1 + end. + +Nondetfunction gen_fma args := + match args with + | (Eop Onegf (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubf (e3:::e1:::e2:::Enil)) + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Nondetfunction gen_fmaf args := + match args with + | (Eop Onegfs (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubfs (e3:::e1:::e2:::Enil)) + | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil)) + | _ => None + end. + +Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := + match b with + | BI_fmin => Some (Eop Ominf args) + | BI_fmax => Some (Eop Omaxf args) + | BI_fminf => Some (Eop Ominfs args) + | BI_fmaxf => Some (Eop Omaxfs args) + | BI_fabsf => Some (Eop Oabsfs args) + | BI_fma => gen_fma args + | BI_fmaf => gen_fmaf args + end. +End SELECT. + +(* Local Variables: *) +(* mode: coq *) +(* End: *) diff --git a/kvx/SelectOpproof.v b/kvx/SelectOpproof.v new file mode 100644 index 00000000..d1d0b95c --- /dev/null +++ b/kvx/SelectOpproof.v @@ -0,0 +1,1735 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Correctness of instruction selection for operators *) + +Require Import Builtins. +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import ExtValues. +Require Import Memory. +Require Import Globalenvs. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import Builtins1. +Require Import SelectOp. +Require Import Events. +Require Import OpHelpers. +Require Import OpHelpersproof. +Require Import DecBoolOps. + +Local Open Scope cminorsel_scope. +Local Open Scope string_scope. + + +(** * Useful lemmas and tactics *) + +(** The following are trivial lemmas and custom tactics that help + perform backward (inversion) and forward reasoning over the evaluation + of operator applications. *) + +Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +Ltac TrivialExists := + match goal with + | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] + end. + +(** * Correctness of the smart constructors *) + +Section CMCONSTR. +Variable prog: program. +Variable hf: helper_functions. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(* Helper lemmas - from SplitLongproof.v *) + +Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto. +Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. + +Lemma eval_helper: + forall le id name sg args vargs vres, + eval_exprlist ge sp e m le args vargs -> + helper_declared prog id name sg -> + external_implements name sg vargs vres -> + eval_expr ge sp e m le (Eexternal id sg args) vres. +Proof. + intros. + red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q). + rewrite <- Genv.find_funct_ptr_iff in Q. + econstructor; eauto. +Qed. + +Corollary eval_helper_1: + forall le id name sg arg1 varg1 vres, + eval_expr ge sp e m le arg1 varg1 -> + helper_declared prog id name sg -> + external_implements name sg (varg1::nil) vres -> + eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres. +Proof. + intros. eapply eval_helper; eauto. constructor; auto. constructor. +Qed. + +Corollary eval_helper_2: + forall le id name sg arg1 arg2 varg1 varg2 vres, + eval_expr ge sp e m le arg1 varg1 -> + eval_expr ge sp e m le arg2 varg2 -> + helper_declared prog id name sg -> + external_implements name sg (varg1::varg2::nil) vres -> + eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. +Proof. + intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor. +Qed. + +(** We now show that the code generated by "smart constructor" functions + such as [Selection.notint] behaves as expected. Continuing the + [notint] example, we show that if the expression [e] + evaluates to some integer value [Vint n], then [Selection.notint e] + evaluates to a value [Vint (Int.not n)] which is indeed the integer + negation of the value of [e]. + + All proofs follow a common pattern: +- Reasoning by case over the result of the classification functions + (such as [add_match] for integer addition), gathering additional + information on the shape of the argument expressions in the non-default + cases. +- Inversion of the evaluations of the arguments, exploiting the additional + information thus gathered. +- Equational reasoning over the arithmetic operations performed, + using the lemmas from the [Int] and [Float] modules. +- Construction of an evaluation derivation for the expression returned + by the smart constructor. +*) + +Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. + +Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := + forall le a x b y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. + +Theorem eval_addrsymbol: + forall le id ofs, + exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. +Proof. + intros. unfold addrsymbol. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addrstack: + forall le ofs, + exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. +Proof. + intros. unfold addrstack. econstructor; split. + EvalOp. simpl; eauto. + auto. +Qed. + +Theorem eval_addimm_shlimm: + forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)). +Proof. + red; unfold addimm_shlimm; intros. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. + - TrivialExists. simpl. + f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e1. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e1. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e2. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e2. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e3. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e3. + rewrite Int.repr_unsigned. + reflexivity. + } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + destruct x; simpl; trivial. + replace (Int.ltu _ _) with true by reflexivity. + unfold Int.ltu. + rewrite e4. + replace (if zlt _ _ then true else false) with true by reflexivity. + rewrite <- e4. + rewrite Int.repr_unsigned. + reflexivity. + } + discriminate. + - unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } + { unfold addx. rewrite Val.add_commut. + TrivialExists. + repeat (try eassumption; try econstructor). + simpl. + reflexivity. + } +Qed. + +Theorem eval_addimm: + forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). +Proof. + red; unfold addimm; intros until x. + predSpec Int.eq Int.eq_spec n Int.zero. + - subst n. intros. exists x; split; auto. + destruct x; simpl; auto. + rewrite Int.add_zero; auto. + - case (addimm_match a); intros; InvEval; simpl. + + TrivialExists; simpl. rewrite Int.add_commut. auto. + + econstructor; split. EvalOp. simpl; eauto. + unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. + + econstructor; split. EvalOp. simpl; eauto. + destruct sp; simpl; auto. + + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. + + TrivialExists; simpl. subst x. + destruct v1; simpl; trivial. + destruct (Int.ltu _ _); simpl; trivial. + rewrite Int.add_assoc. rewrite Int.add_commut. + reflexivity. + + pose proof eval_addimm_shlimm as ADDX. + unfold unary_constructor_sound in ADDX. + unfold addx in ADDX. + rewrite Val.add_commut. + subst x. + apply ADDX; assumption. + + TrivialExists. +Qed. + +Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n). +Proof. + red. + intros. + unfold add_shlimm. + destruct (Compopts.optim_addx tt). + { + destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. + - TrivialExists. + simpl. + f_equal. f_equal. + unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. + destruct (Z.eq_dec _ _) as [e1|]. + { replace s14 with SHIFT1 by congruence. + rewrite <- e1. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e2|]. + { replace s14 with SHIFT2 by congruence. + rewrite <- e2. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e3|]. + { replace s14 with SHIFT3 by congruence. + rewrite <- e3. + apply Int.repr_unsigned. } + destruct (Z.eq_dec _ _) as [e4|]. + { replace s14 with SHIFT4 by congruence. + rewrite <- e4. + apply Int.repr_unsigned. } + discriminate. + - TrivialExists; + repeat econstructor; eassumption. + } + { TrivialExists; + repeat econstructor; eassumption. + } +Qed. + +Theorem eval_add: binary_constructor_sound add Val.add. +Proof. + red; intros until y. + unfold add; case (add_match a b); intros; InvEval. + - rewrite Val.add_commut. apply eval_addimm; auto. + - apply eval_addimm; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) + with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + rewrite Val.add_commut. destruct sp; simpl; auto. + destruct v1; simpl; auto. + - subst. econstructor; split. + EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. + destruct sp; simpl; auto. + destruct v1; simpl; auto. + - subst. + replace (Val.add (Val.add v1 (Vint n1)) y) + with (Val.add (Val.add v1 y) (Vint n1)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. + - subst. + replace (Val.add x (Val.add v1 (Vint n2))) + with (Val.add (Val.add x v1) (Vint n2)). + apply eval_addimm. EvalOp. + repeat rewrite Val.add_assoc. reflexivity. + - (* Omadd *) + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + - (* Omadd rev *) + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + simpl. rewrite Val.add_commut. reflexivity. + - (* Omaddimm *) + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + - (* Omaddimm rev *) + subst. destruct (Compopts.optim_madd tt); TrivialExists; + repeat (eauto; econstructor; simpl). + simpl. rewrite Val.add_commut. reflexivity. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + rewrite Val.add_commut. + apply ADDX; assumption. + (* Oaddx *) + - subst. pose proof eval_addx as ADDX. + unfold binary_constructor_sound in ADDX. + apply ADDX; assumption. + - TrivialExists. +Qed. + +Theorem eval_sub: binary_constructor_sound sub Val.sub. +Proof. + red; intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + - rewrite Val.sub_add_opp. apply eval_addimm; auto. + - subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. + rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. + apply eval_addimm; EvalOp. + - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. + - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. + - TrivialExists. simpl. subst. reflexivity. + - destruct (Compopts.optim_madd tt). + + TrivialExists. simpl. subst. + rewrite sub_add_neg. + rewrite neg_mul_distr_r. + unfold Val.neg. + reflexivity. + + TrivialExists. repeat (eauto; econstructor). + simpl. subst. reflexivity. + - TrivialExists. +Qed. + +Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). +Proof. + red; intros until x. unfold negint. case (negint_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_shlimm: + forall n, unary_constructor_sound (fun a => shlimm a n) + (fun x => Val.shl x (Vint n)). +Proof. + red; intros until x. unfold shlimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. + destruct (shlimm_match a); intros; InvEval. + - exists (Vint (Int.shl n1 n)); split. EvalOp. + simpl. rewrite LT. auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto. + rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. + + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shruimm: + forall n, unary_constructor_sound (fun a => shruimm a n) + (fun x => Val.shru x (Vint n)). +Proof. + red; intros until x. unfold shruimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT. + destruct (shruimm_match a); intros; InvEval. + - exists (Vint (Int.shru n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - subst x. + simpl negb. + cbn iota. + destruct (is_bitfield _ _) eqn:BOUNDS. + + exists (extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold extfz. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int.zwordsize + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int.zwordsize + (Z.sub + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Theorem eval_shrimm: + forall n, unary_constructor_sound (fun a => shrimm a n) + (fun x => Val.shr x (Vint n)). +Proof. + red; intros until x. unfold shrimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. + + destruct (Int.ltu n Int.iwordsize) eqn:LT. + destruct (shrimm_match a); intros; InvEval. + - exists (Vint (Int.shr n1 n)); split. EvalOp. + simpl. rewrite LT; auto. + - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. + exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. + subst. destruct v1; simpl; auto. + rewrite Heqb. + destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. + rewrite LT. + rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. + simpl. auto. + - subst x. + simpl negb. + cbn iota. + destruct (is_bitfield _ _) eqn:BOUNDS. + + exists (extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize) v1). + split. + ++ EvalOp. + ++ unfold extfs. + rewrite BOUNDS. + destruct v1; try (simpl; apply Val.lessdef_undef). + replace (Z.sub Int.zwordsize + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. + replace (Z.sub Int.zwordsize + (Z.sub + (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) + (Z.sub + (Z.add + (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) + Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. + rewrite Int.repr_unsigned. + rewrite Int.repr_unsigned. + simpl. + destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. + simpl. + destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. + + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. + - TrivialExists. + - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. + auto. +Qed. + +Lemma eval_mulimm_base: + forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros; unfold mulimm_base. + + assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v). + TrivialExists. econstructor. EvalOp. simpl; eauto. econstructor. eauto. constructor. + rewrite Val.mul_commut. auto. + + generalize (Int.one_bits_decomp n). + generalize (Int.one_bits_range n). + destruct (Int.one_bits n). + - intros. TrivialExists. + - destruct l. + + intros. rewrite H1. simpl. + rewrite Int.add_zero. + replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. + apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. + + destruct l. + intros. rewrite H1. simpl. + exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. + exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. + exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]]. + exists v; split. econstructor; eauto. + rewrite Int.add_zero. + replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) + with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). + rewrite Val.mul_add_distr_r. + repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. + simpl. repeat rewrite H0; auto with coqlib. + intros. TrivialExists. +Qed. + +Theorem eval_mulimm: + forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). +Proof. + intros; red; intros until x; unfold mulimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.one. + intros. exists x; split; auto. + destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. + + case (mulimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.mul_commut; auto. + - subst. rewrite Val.mul_add_distr_l. + exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. + exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. + exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. + rewrite Val.mul_commut; auto. + - apply eval_mulimm_base; auto. +Qed. + +Theorem eval_mul: binary_constructor_sound mul Val.mul. +Proof. + red; intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Val.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + TrivialExists. +Qed. + +Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs. +Proof. + red; intros. unfold mulhs; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. + apply Val.lessdef_same. f_equal. + transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). + unfold Int.mulhs; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shr' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. +Proof. + red; intros. unfold mulhu; destruct Archi.ptr64 eqn:SF. +- econstructor; split. + EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. + constructor. EvalOp. simpl; eauto. constructor. + simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. + destruct x; simpl; auto. destruct y; simpl; auto. + change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. + apply Val.lessdef_same. f_equal. + transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). + unfold Int.mulhu; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. + apply Int.same_bits_eq; intros n N. + change Int.zwordsize with 32 in *. + assert (N1: 0 <= n < 64) by omega. + rewrite Int64.bits_loword by auto. + rewrite Int64.bits_shru' by auto. + change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. + rewrite zlt_true by omega. + rewrite Int.testbit_repr by auto. + unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). + transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). + rewrite Z.shiftr_spec by omega. auto. + apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. + change Int64.zwordsize with 64; omega. +- TrivialExists. +Qed. + +Theorem eval_andimm: + forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). +Proof. + intros; red; intros until x. unfold andimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. exists (Vint Int.zero); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists x; split; auto. + subst. destruct x; simpl; auto. rewrite Int.and_mone; auto. + + case (andimm_match a); intros. + - InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. + - InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. + - InvEval. TrivialExists. simpl; congruence. + - TrivialExists. +Qed. + +Theorem eval_and: binary_constructor_sound and Val.and. +Proof. + red; intros until y; unfold and; case (and_match a b); intros; InvEval. + - rewrite Val.and_commut. apply eval_andimm; auto. + - apply eval_andimm; auto. + - (*andn*) TrivialExists; simpl; congruence. + - (*andn reverse*) rewrite Val.and_commut. TrivialExists; simpl; congruence. + - TrivialExists. +Qed. + +Theorem eval_orimm: + forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). +Proof. + intros; red; intros until x. unfold orimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + intros. subst. exists x; split; auto. + destruct x; simpl; auto. rewrite Int.or_zero; auto. + + predSpec Int.eq Int.eq_spec n Int.mone. + intros. exists (Vint Int.mone); split. EvalOp. + destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. + + destruct (orimm_match a); intros; InvEval. + - TrivialExists. simpl. rewrite Int.or_commut; auto. + - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. + - InvEval. TrivialExists. simpl; congruence. + - TrivialExists. +Qed. + + +Remark eval_same_expr: + forall a1 a2 le v1 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + a1 = a2 /\ v1 = v2. +Proof. + intros until v2. + destruct a1; simpl; try (intros; discriminate). + destruct a2; simpl; try (intros; discriminate). + case (ident_eq i i0); intros. + subst i0. inversion H0. inversion H1. split. auto. congruence. + discriminate. +Qed. + +Lemma int_eq_commut: forall x y : int, + (Int.eq x y) = (Int.eq y x). +Proof. + intros. + predSpec Int.eq Int.eq_spec x y; + predSpec Int.eq Int.eq_spec y x; + congruence. +Qed. + +Theorem eval_or: binary_constructor_sound or Val.or. +Proof. + unfold or; red; intros. + assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oor (a:::b:::Enil)) v /\ Val.lessdef (Val.or x y) v) by TrivialExists. + assert (ROR: forall v n1 n2, + Int.add n1 n2 = Int.iwordsize -> + Val.lessdef (Val.or (Val.shl v (Vint n1)) (Val.shru v (Vint n2))) + (Val.ror v (Vint n2))). + { intros. destruct v; simpl; auto. + destruct (Int.ltu n1 Int.iwordsize) eqn:N1; auto. + destruct (Int.ltu n2 Int.iwordsize) eqn:N2; auto. + simpl. rewrite <- Int.or_ror; auto. } + + destruct (or_match a b); InvEval. + + - rewrite Val.or_commut. apply eval_orimm; auto. + - apply eval_orimm; auto. + - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v0 (Vint n2)); split. EvalOp. apply ROR; auto. + - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. + destruct (same_expr_pure t1 t2) eqn:?; auto. + InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. + exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. + - (*orn*) TrivialExists; simpl; congruence. + - (*orn reversed*) rewrite Val.or_commut. TrivialExists; simpl; congruence. + - set (zstop := (int_highest_bit mask)). + set (zstart := (Int.unsigned start)). + destruct (is_bitfield _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * simpl in H6. + injection H6. + clear H6. + intro. subst y. subst x. + TrivialExists. simpl. f_equal. + unfold insf. + rewrite Risbitfield. + rewrite Rmask. + rewrite Rnmask. + simpl. + unfold bitfield_mask. + subst v0. + subst zstart. + rewrite Int.repr_unsigned. + reflexivity. + * apply DEFAULT. + + apply DEFAULT. + - set (zstop := (int_highest_bit mask)). + set (zstart := 0). + destruct (is_bitfield _ _) eqn:Risbitfield. + + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. + * subst y. subst x. + TrivialExists. simpl. f_equal. + unfold insf. + rewrite Risbitfield. + rewrite Rmask. + rewrite Rnmask. + simpl. + unfold bitfield_mask. + subst zstart. + rewrite (Val.or_commut (Val.and v1 _)). + rewrite (Val.or_commut (Val.and v1 _)). + destruct v0; simpl; trivial. + unfold Int.ltu, Int.iwordsize, Int.zwordsize. + rewrite Int.unsigned_repr. + ** rewrite Int.unsigned_repr. + *** simpl. + rewrite Int.shl_zero. + reflexivity. + *** simpl. + unfold Int.max_unsigned, Int.modulus. + simpl. + omega. + ** unfold Int.max_unsigned, Int.modulus. + simpl. + omega. + * apply DEFAULT. + + apply DEFAULT. + - apply DEFAULT. +Qed. + +Theorem eval_xorimm: + forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). +Proof. + intros; red; intros until x. unfold xorimm. + + predSpec Int.eq Int.eq_spec n Int.zero. + - intros. exists x; split. auto. + destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. + - predSpec Int.eq Int.eq_spec n Int.mone. + -- subst n. intros. rewrite <- Val.not_xor. TrivialExists. + -- intros. destruct (xorimm_match a); intros; InvEval. + + TrivialExists. simpl. rewrite Int.xor_commut; auto. + + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. + predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. + * exists v1; split; auto. destruct v1; simpl; auto. rewrite H1, Int.xor_zero; auto. + * TrivialExists. + + TrivialExists. +Qed. + +Theorem eval_xor: binary_constructor_sound xor Val.xor. +Proof. + red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. + - rewrite Val.xor_commut. apply eval_xorimm; auto. + - apply eval_xorimm; auto. + - TrivialExists. +Qed. + +Theorem eval_notint: unary_constructor_sound notint Val.notint. +Proof. + assert (forall v, Val.lessdef (Val.notint (Val.notint v)) v). + destruct v; simpl; auto. rewrite Int.not_involutive; auto. + unfold notint; red; intros until x; case (notint_match a); intros; InvEval. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - TrivialExists; simpl; congruence. + - subst x. exists (Val.and v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.and v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.or v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.or v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + - subst x. exists (Val.xor v1 v0); split; trivial. + econstructor. constructor. eassumption. constructor. + eassumption. constructor. simpl. reflexivity. + - subst x. exists (Val.xor v1 (Vint n)); split; trivial. + econstructor. constructor. eassumption. constructor. + simpl. reflexivity. + (* andn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_and_or_not. + rewrite Int.not_involutive. + apply Int.or_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_and_or_not. + rewrite Int.not_involutive. + reflexivity. + (* orn *) + - subst x. TrivialExists. simpl. + destruct v0; destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_or_and_not. + rewrite Int.not_involutive. + apply Int.and_commut. + - subst x. TrivialExists. simpl. + destruct v1; simpl; trivial. + f_equal. f_equal. + rewrite Int.not_or_and_not. + rewrite Int.not_involutive. + reflexivity. + - subst x. exists v1; split; trivial. + - TrivialExists. + - TrivialExists. +Qed. + +Theorem eval_divs_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divs x y = Some z -> + exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. +Proof. + intros; unfold divs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +Theorem eval_mods_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.mods x y = Some z -> + exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. +Proof. + intros; unfold mods_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +Theorem eval_divu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.divu x y = Some z -> + exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. +Proof. + intros; unfold divu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +(* For using 64-bit unsigned division for 32-bit + + intros until z. + intros Hax Hby Hdiv. unfold divu_base. + pose proof (divu_is_divlu x y) as DIVU. + destruct (Val.divlu (Val.longofintu x) (Val.longofintu y)) + as [ ql | ] eqn:Ediv. + { TrivialExists. + { econstructor. eapply eval_helper_2; eauto. + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { DeclHelper. } + { UseHelper. } + constructor. } + simpl. + congruence. + } + congruence. +Qed. + *) + +Theorem eval_modu_base: + forall le a b x y z, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + Val.modu x y = Some z -> + exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. +Proof. + intros; unfold modu_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +(* for using 64-bit unsigned modulo for 32-bit + + intros until z. + intros Hax Hby Hmod. unfold modu_base. + pose proof (modu_is_modlu x y) as MODU. + destruct (Val.modlu (Val.longofintu x) (Val.longofintu y)) + as [ ql | ] eqn:Emod. + { TrivialExists. + { econstructor. eapply eval_helper_2; eauto. + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { econstructor. econstructor. eassumption. + constructor. simpl. reflexivity. } + { DeclHelper. } + { UseHelper. } + constructor. } + simpl. + congruence. + } + congruence. +Qed. + *) + +Theorem eval_shrximm: + forall le a n x z, + eval_expr ge sp e m le a x -> + Val.shrx x (Vint n) = Some z -> + exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v. +Proof. + intros. unfold shrximm. + predSpec Int.eq Int.eq_spec n Int.zero. + subst n. exists x; split; auto. + destruct x; simpl in H0; try discriminate. + destruct (Int.ltu Int.zero (Int.repr 31)); inv H0. + replace (Int.shrx i Int.zero) with i. auto. + unfold Int.shrx, Int.divs. rewrite Int.shl_zero. + change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. + econstructor; split. EvalOp. + simpl. rewrite H0. simpl. reflexivity. auto. +Qed. + +Theorem eval_shl: binary_constructor_sound shl Val.shl. +Proof. + red; intros until y; unfold shl; case (shl_match b); intros. + InvEval. apply eval_shlimm; auto. + TrivialExists. +Qed. + +Theorem eval_shr: binary_constructor_sound shr Val.shr. +Proof. + red; intros until y; unfold shr; case (shr_match b); intros. + InvEval. apply eval_shrimm; auto. + TrivialExists. +Qed. + +Theorem eval_shru: binary_constructor_sound shru Val.shru. +Proof. + red; intros until y; unfold shru; case (shru_match b); intros. + InvEval. apply eval_shruimm; auto. + TrivialExists. +Qed. + +Theorem eval_negf: unary_constructor_sound negf Val.negf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absf: unary_constructor_sound absf Val.absf. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addf: binary_constructor_sound addf Val.addf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subf: binary_constructor_sound subf Val.subf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_negfs: unary_constructor_sound negfs Val.negfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_absfs: unary_constructor_sound absfs Val.absfs. +Proof. + red; intros. TrivialExists. +Qed. + +Theorem eval_addfs: binary_constructor_sound addfs Val.addfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_subfs: binary_constructor_sound subfs Val.subfs. +Proof. + red; intros; TrivialExists. +Qed. + +Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs. +Proof. + red; intros; TrivialExists. +Qed. + +Section COMP_IMM. + +Variable default: comparison -> int -> condition. +Variable intsem: comparison -> int -> int -> bool. +Variable sem: comparison -> val -> val -> val. + +Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y). +Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef. +Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y). +Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)). +Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m). + +Lemma eval_compimm: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v + /\ Val.lessdef (sem c x (Vint n2)) v. +Proof. + intros until x. + unfold compimm; case (compimm_match c a); intros. +(* constant *) + - InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. +(* eq cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. + rewrite sem_undef; auto. + exists (Vint Int.zero); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* ne cmp *) + - InvEval. inv H. simpl in H5. inv H5. + destruct (Int.eq_dec n2 Int.zero). + + subst n2. TrivialExists. + simpl. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. + simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. + rewrite sem_undef; auto. + exists (Vint Int.one); split. EvalOp. + destruct (eval_condition c0 vl m); simpl. + unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. + rewrite sem_undef; auto. +(* default *) + - TrivialExists. simpl. rewrite sem_default. auto. +Qed. + +Hypothesis sem_swap: + forall c x y, sem (swap_comparison c) x y = sem c y x. + +Lemma eval_compimm_swap: + forall le c a n2 x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v + /\ Val.lessdef (sem c (Vint n2) x) v. +Proof. + intros. rewrite <- sem_swap. eapply eval_compimm; eauto. +Qed. + +End COMP_IMM. + +Theorem eval_comp: + forall c, binary_constructor_sound (comp c) (Val.cmp c). +Proof. + intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compu: + forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). +Proof. + intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. + eapply eval_compimm_swap; eauto. + intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. + eapply eval_compimm; eauto. + TrivialExists. +Qed. + +Theorem eval_compf: + forall c, binary_constructor_sound (compf c) (Val.cmpf c). +Proof. + intros; red; intros. unfold compf. TrivialExists. +Qed. + +Theorem eval_compfs: + forall c, binary_constructor_sound (compfs c) (Val.cmpfs c). +Proof. + intros; red; intros. unfold compfs. TrivialExists. +Qed. + +Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). +Proof. + red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). +Proof. + red; intros until x. unfold cast8unsigned. + + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. +Qed. + +Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). +Proof. + red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval. + TrivialExists. + TrivialExists. +Qed. + +Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). +Proof. + red; intros until x. unfold cast8unsigned. + rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. +Qed. + +Theorem eval_intoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intoffloat. TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_intuoffloat: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuoffloat x = Some y -> + exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuoffloat. TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_floatofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofintu x = Some y -> + exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. +Proof. + intros. + unfold Val.floatofintu in *. + unfold floatofintu. + destruct (floatofintu_match a). + - InvEval. + TrivialExists. + - InvEval. + TrivialExists. + constructor. econstructor. constructor. eassumption. constructor. + simpl. f_equal. constructor. + simpl. + destruct x; simpl; trivial; try discriminate. + f_equal. + inv H0. + f_equal. + rewrite Float.of_intu_of_longu. + reflexivity. +Qed. + +Theorem eval_floatofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.floatofint x = Some y -> + exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. +Proof. + intros. + unfold floatofint. + destruct (floatofint_match a). + - InvEval. + TrivialExists. + - InvEval. + TrivialExists. + constructor. econstructor. constructor. eassumption. constructor. + simpl. f_equal. constructor. + simpl. + destruct x; simpl; trivial; try discriminate. + f_equal. + inv H0. + f_equal. + rewrite Float.of_int_of_long. + reflexivity. +Qed. + +Theorem eval_intofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_singleofint: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofint x = Some y -> + exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. +Proof. + intros; unfold singleofint; TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_intuofsingle: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.intuofsingle x = Some y -> + exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_singleofintu: + forall le a x y, + eval_expr ge sp e m le a x -> + Val.singleofintu x = Some y -> + exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. +Proof. + intros; unfold intuofsingle. TrivialExists. + simpl. rewrite H0. reflexivity. +Qed. + +Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. +Proof. + red; intros. unfold singleoffloat. TrivialExists. +Qed. + +Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. +Proof. + red; intros. unfold floatofsingle. TrivialExists. +Qed. + +Theorem eval_addressing: + forall le chunk a v b ofs, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + match addressing chunk a with (mode, args) => + exists vl, + eval_exprlist ge sp e m le args vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros; InvEval. + - exists (@nil val); split. eauto with evalexpr. simpl. auto. + - destruct (orb _ _). + + exists (Vptr b ofs0 :: nil); split. + constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. + + exists (@nil val); split. constructor. simpl; auto. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. + - exists (v1 :: nil); split. eauto with evalexpr. simpl. + destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. + simpl. auto. + - destruct (Compopts.optim_xsaddr tt). + + destruct (Z.eq_dec _ _). + * exists (v1 :: v2 :: nil); split. + repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. + * exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. + + exists (v1 :: v0 :: nil); split. + repeat (constructor; auto). econstructor. + repeat (constructor; auto). eassumption. simpl. congruence. + simpl. congruence. + - unfold addxl in *. + destruct (Compopts.optim_xsaddr tt). + + unfold int_of_shift1_4 in *. + destruct (Z.eq_dec _ _). + * exists (v0 :: v1 :: nil); split. + repeat (constructor; auto). simpl. + congruence. + * eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. + simpl. congruence. + + eexists; split. + repeat (constructor; auto). eassumption. + econstructor. + repeat (constructor; auto). eassumption. simpl. + reflexivity. + simpl. unfold int_of_shift1_4 in *. congruence. + - exists (v1 :: v0 :: nil); split. repeat (constructor; auto). simpl. congruence. + - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. +Qed. + +Theorem eval_builtin_arg: + forall a v, + eval_expr ge sp e m nil a v -> + CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. +Proof. + intros until v. unfold builtin_arg; case (builtin_arg_match a); intros. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. constructor. +- InvEval. simpl in H5. inv H5. constructor. +- InvEval. subst v. constructor; auto. +- inv H. InvEval. simpl in H6; inv H6. constructor; auto. +- destruct Archi.ptr64 eqn:SF. ++ constructor; auto. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vint n) else Val.add v1 (Vint n)). + repeat constructor; auto. + rewrite SF; auto. +- destruct Archi.ptr64 eqn:SF. ++ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vlong n) else Val.add v1 (Vlong n)). + repeat constructor; auto. ++ constructor; auto. +- constructor; auto. +Qed. + +(* ternary *) +(* does not work due to possible nondeterminism +Lemma cond_to_condition0_correct : + forall cond : condition, + forall al : exprlist, + match (cond_to_condition0 cond al) with + | None => True + | Some(cond0, e1) => + forall le vl v1, + eval_expr ge sp e m le e1 v1 -> + eval_exprlist ge sp e m le al vl -> + (eval_condition0 cond0 v1 m) = (eval_condition cond vl m) + end. +Proof. + intros. + unfold cond_to_condition0. + case (cond_to_condition0_match cond al); trivial. + { + intros. + destruct (Int.eq_dec _ _); trivial. + intros until v1. + intros He1 Hel. + InvEval. + simpl. + f_equal. + eapply eval_expr_determ. eassumption. + } +Qed. +*) + +Lemma eval_neg_condition0: + forall cond0: condition0, + forall v1: val, + forall m: mem, + (eval_condition0 (negate_condition0 cond0) v1 m) = + option_map negb (eval_condition0 cond0 v1 m). +Proof. + intros. + destruct cond0; simpl; + try rewrite Val.negate_cmp_bool; + try rewrite Val.negate_cmpu_bool; + try rewrite Val.negate_cmpl_bool; + try rewrite Val.negate_cmplu_bool; + reflexivity. +Qed. + +Lemma select_neg: + forall a b c, + Val.select (option_map negb a) b c = + Val.select a c b. +Proof. + destruct a; simpl; trivial. + destruct b; simpl; trivial. +Qed. + +Lemma eval_select0: + forall le ty cond0 ac vc a1 v1 a2 v2, + eval_expr ge sp e m le ac vc -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + exists v, + eval_expr ge sp e m le (select0 ty cond0 a1 a2 ac) v + /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. +Proof. + intros. + unfold select0. + destruct (select0_match ty cond0 a1 a2 ac). + all: InvEval; econstructor; split; + try repeat (try econstructor; try eassumption). + all: rewrite eval_neg_condition0; rewrite select_neg; constructor. +Qed. + +Lemma bool_cond0_ne: + forall ob : option bool, + forall m, + (eval_condition0 (Ccomp0 Cne) (Val.of_optbool ob) m) = ob. +Proof. + destruct ob; simpl; trivial. + intro. + destruct b; reflexivity. +Qed. + +Lemma eval_condition_ccomp_swap : + forall c x y m, + eval_condition (Ccomp (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomp c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmp_bool. +Qed. + +Lemma eval_condition_ccompu_swap : + forall c x y m, + eval_condition (Ccompu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpu_bool. +Qed. + +Lemma eval_condition_ccompl_swap : + forall c x y m, + eval_condition (Ccompl (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccompl c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmpl_bool. +Qed. + +Lemma eval_condition_ccomplu_swap : + forall c x y m, + eval_condition (Ccomplu (swap_comparison c)) (x :: y :: nil) m= + eval_condition (Ccomplu c) (y :: x :: nil) m. +Proof. + intros; unfold eval_condition; + apply Val.swap_cmplu_bool. +Qed. + +Theorem eval_select: + forall le ty cond al vl a1 v1 a2 v2 a b, + select ty cond al a1 a2 = Some a -> + eval_exprlist ge sp e m le al vl -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_condition cond vl m = Some b -> + exists v, + eval_expr ge sp e m le a v + /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. +Proof. + unfold select. + intros until b. + intro Hop; injection Hop; clear Hop; intro; subst a. + intros HeL He1 He2 HeC. + unfold cond_to_condition0. + destruct (cond_to_condition0_match cond al). + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmp_bool c v0 (Vint Int.zero)) + with (eval_condition0 (Ccomp0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int.eq_dec x Int.zero). + { subst x. + simpl. + change (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint Int.zero)) + with (eval_condition0 (Ccompu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmpl_bool c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccompl0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + { + InvEval. + rewrite <- HeC. + destruct (Int64.eq_dec x Int64.zero). + { subst x. + simpl. + change (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong Int64.zero)) + with (eval_condition0 (Ccomplu0 c) v0 m). + eapply eval_select0; eassumption. + } + simpl. + erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). + eapply eval_select0; repeat (try econstructor; try eassumption). + } + erewrite <- (bool_cond0_ne (Some b)). + eapply eval_select0; repeat (try econstructor; try eassumption). + rewrite <- HeC. + simpl. + reflexivity. +Qed. + +(* floating-point division *) +Theorem eval_divf_base: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divf_base a b) v /\ Val.lessdef (Val.divf x y) v. +Proof. + intros; unfold divf_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + + +Lemma eval_divfs_base1: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divfs_base1 b) v /\ Val.lessdef (ExtValues.invfs y) v. +Proof. + intros; unfold divfs_base1. + econstructor; split. + repeat (try econstructor; try eassumption). + trivial. +Qed. + +Lemma eval_divfs_baseX: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divfs_baseX a b) v /\ Val.lessdef (Val.divfs x y) v. +Proof. + intros; unfold divfs_base. + econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. +Qed. + +Theorem eval_divfs_base: + forall le a b x y, + eval_expr ge sp e m le a x -> + eval_expr ge sp e m le b y -> + exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v. +Proof. + intros; unfold divfs_base. + destruct (divfs_base_match _). + - destruct (Float32.eq_dec _ _). + + exists (Val.divfs x y). + split; trivial. repeat (try econstructor; try eassumption). + simpl. InvEval. reflexivity. + + apply eval_divfs_baseX; assumption. + - apply eval_divfs_baseX; assumption. +Qed. + +(** Platform-specific known builtins *) + +Lemma eval_fma: + forall al a vl v le, + gen_fma al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fma vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fma. + intros until le. + intro Heval. + destruct (gen_fma_match _) in *; try discriminate. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + +Lemma eval_fmaf: + forall al a vl v le, + gen_fmaf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem BI_fmaf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + unfold gen_fmaf. + intros until le. + intro Heval. + destruct (gen_fmaf_match _) in *; try discriminate. + all: inversion Heval; subst a; clear Heval; intro; InvEval. + - subst v1. + TrivialExists. + destruct v0; simpl; trivial; + destruct v2; simpl; trivial; + destruct v3; simpl; trivial. + - intro Heval. + simpl in Heval. + inv Heval. + TrivialExists. + destruct v0; simpl; trivial; + destruct v1; simpl; trivial; + destruct v2; simpl; trivial. +Qed. + +Theorem eval_platform_builtin: + forall bf al a vl v le, + platform_builtin bf al = Some a -> + eval_exprlist ge sp e m le al vl -> + platform_builtin_sem bf vl = Some v -> + exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. +Proof. + destruct bf; intros until le; intro Heval. + all: try (inversion Heval; subst a; clear Heval; + exists v; split; trivial; + repeat (try econstructor; try eassumption)). + - apply eval_fma; assumption. + - apply eval_fmaf; assumption. +Qed. + +End CMCONSTR. diff --git a/kvx/Stacklayout.v b/kvx/Stacklayout.v new file mode 100644 index 00000000..46202e03 --- /dev/null +++ b/kvx/Stacklayout.v @@ -0,0 +1,150 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import AST Memory Separation. +Require Import Bounds. + +Local Open Scope sep_scope. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- Space for outgoing arguments to function calls. +- Back link to parent frame +- Return address +- Saved values of callee-save registers used by the function. +- Local stack slots. +- Space for the stack-allocated data declared in Cminor. + +The stack pointer is kept 16-aligned. +*) + +Definition fe_ofs_arg := 0. + +Definition make_env (b: bounds) : frame_env := + let w := if Archi.ptr64 then 8 else 4 in + let olink := align (4 * b.(bound_outgoing)) w in (* back link *) + let oretaddr := olink + w in (* return address *) + let ocs := oretaddr + w in (* callee-saves *) + let ol := align (size_callee_save_area b ocs) 8 in (* locals *) + let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) + let sz := align (ostkdata + b.(bound_stack_data)) 16 in + {| fe_size := sz; + fe_ofs_link := olink; + fe_ofs_retaddr := oretaddr; + fe_ofs_local := ol; + fe_ofs_callee_save := ocs; + fe_stack_data := ostkdata; + fe_used_callee_save := b.(used_callee_save) |}. + +Lemma frame_env_separated: + forall b sp m P, + let fe := make_env b in + m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> + m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) + ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) + ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) + ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) + ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) + ** P. +Proof. +Local Opaque Z.add Z.mul sepconj range. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). +(* Reorder as: + outgoing + back link + retaddr + callee-save + local *) + rewrite sep_swap12. + rewrite sep_swap23. + rewrite sep_swap34. + rewrite sep_swap45. +(* Apply range_split and range_split2 repeatedly *) + unfold fe_ofs_arg. + apply range_split_2. fold olink; omega. omega. + apply range_split. omega. + apply range_split. omega. + apply range_split_2. fold ol. omega. omega. + apply range_drop_right with ostkdata. omega. + eapply sep_drop2. eexact H. +Qed. + +Lemma frame_env_range: + forall b, + let fe := make_env b in + 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. + assert (0 <= 4 * b.(bound_outgoing)) by omega. + assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). + assert (olink + w <= oretaddr) by (unfold oretaddr; omega). + assert (oretaddr + w <= ocs) by (unfold ocs; omega). + assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). + assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). + assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). + split. omega. apply align_le. omega. +Qed. + +Lemma frame_env_aligned: + forall b, + let fe := make_env b in + (8 | fe_ofs_arg) + /\ (8 | fe_ofs_local fe) + /\ (8 | fe_stack_data fe) + /\ (align_chunk Mptr | fe_ofs_link fe) + /\ (align_chunk Mptr | fe_ofs_retaddr fe). +Proof. + intros; simpl. + set (w := if Archi.ptr64 then 8 else 4). + set (olink := align (4 * b.(bound_outgoing)) w). + set (oretaddr := olink + w). + set (ocs := oretaddr + w). + set (ol := align (size_callee_save_area b ocs) 8). + set (ostkdata := align (ol + 4 * b.(bound_local)) 8). + assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). + replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). + split. apply Z.divide_0_r. + split. apply align_divides; omega. + split. apply align_divides; omega. + split. apply align_divides; omega. + apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. +Qed. diff --git a/kvx/TargetPrinter.ml b/kvx/TargetPrinter.ml new file mode 100644 index 00000000..dfafc137 --- /dev/null +++ b/kvx/TargetPrinter.ml @@ -0,0 +1,887 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(* Printing RISC-V assembly code in asm syntax *) + +open Printf +open Camlcoq +open Sections +open AST +open Asm +open PrintAsmaux +open Fileinfo + +(* Module containing the printing functions *) + +module Target (*: TARGET*) = + struct + +(* Basic printing functions *) + + let comment = "#" + + type idiv_function_kind = + | Idiv_system + | Idiv_stsud + | Idiv_fp;; + + let idiv_function_kind = function + "stsud" -> Idiv_stsud + | "system" -> Idiv_system + | "fp" -> Idiv_fp + | _ -> failwith "unknown integer division kind";; + + let idiv_function_kind_32bit () = idiv_function_kind !Clflags.option_div_i32;; + let idiv_function_kind_64bit () = idiv_function_kind !Clflags.option_div_i64;; + + let subst_symbol = function + "__compcert_i64_udiv" -> + (match idiv_function_kind_64bit () with + | Idiv_system | Idiv_fp -> "__udivdi3" + | Idiv_stsud -> "__compcert_i64_udiv_stsud") + | "__compcert_i64_sdiv" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__divdi3" + | Idiv_stsud -> "__compcert_i64_sdiv_stsud") + | "__compcert_i64_umod" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__umoddi3" + | Idiv_stsud -> "__compcert_i64_umod_stsud") + | "__compcert_i64_smod" -> + (match idiv_function_kind_64bit() with + | Idiv_system | Idiv_fp -> "__moddi3" + | Idiv_stsud -> "__compcert_i64_smod_stsud") + | "__compcert_i32_sdiv" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_sdiv_fp" + | Idiv_stsud -> "__compcert_i32_sdiv_stsud") + | "__compcert_i32_udiv" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_udiv_fp" + | Idiv_stsud -> "__compcert_i32_udiv_stsud") + | "__compcert_i32_smod" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_smod_fp" + | Idiv_stsud -> "__compcert_i32_smod_stsud") + | "__compcert_i32_umod" as s -> + (match idiv_function_kind_32bit() with + | Idiv_system -> s + | Idiv_fp -> "__compcert_i32_umod_fp" + | Idiv_stsud -> "__compcert_i32_umod_stsud") + | "__compcert_f64_div" -> "__divdf3" + | "__compcert_f32_div" -> "__divsf3" + | x -> x;; + + let symbol oc symb = + fprintf oc "%s" (subst_symbol (extern_atom symb)) + + let symbol_offset oc (symb, ofs) = + symbol oc symb; + let ofs = camlint64_of_ptrofs ofs in + if ofs <> 0L then fprintf oc " + %Ld" ofs + + let label = elf_label + + let print_label oc lbl = label oc (transl_label lbl) + + let int_reg_name = let open Asmvliw in function + + | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" + | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" + | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" + | GPR12 -> "$r12" | GPR13 -> "$r13" | GPR14 -> "$r14" | GPR15 -> "$r15" + | GPR16 -> "$r16" | GPR17 -> "$r17" | GPR18 -> "$r18" | GPR19 -> "$r19" + | GPR20 -> "$r20" | GPR21 -> "$r21" | GPR22 -> "$r22" | GPR23 -> "$r23" + | GPR24 -> "$r24" | GPR25 -> "$r25" | GPR26 -> "$r26" | GPR27 -> "$r27" + | GPR28 -> "$r28" | GPR29 -> "$r29" | GPR30 -> "$r30" | GPR31 -> "$r31" + | GPR32 -> "$r32" | GPR33 -> "$r33" | GPR34 -> "$r34" | GPR35 -> "$r35" + | GPR36 -> "$r36" | GPR37 -> "$r37" | GPR38 -> "$r38" | GPR39 -> "$r39" + | GPR40 -> "$r40" | GPR41 -> "$r41" | GPR42 -> "$r42" | GPR43 -> "$r43" + | GPR44 -> "$r44" | GPR45 -> "$r45" | GPR46 -> "$r46" | GPR47 -> "$r47" + | GPR48 -> "$r48" | GPR49 -> "$r49" | GPR50 -> "$r50" | GPR51 -> "$r51" + | GPR52 -> "$r52" | GPR53 -> "$r53" | GPR54 -> "$r54" | GPR55 -> "$r55" + | GPR56 -> "$r56" | GPR57 -> "$r57" | GPR58 -> "$r58" | GPR59 -> "$r59" + | GPR60 -> "$r60" | GPR61 -> "$r61" | GPR62 -> "$r62" | GPR63 -> "$r63" + + let ireg oc r = output_string oc (int_reg_name r) + + let int_gpreg_q_name = + let open Asmvliw in + function + | R0R1 -> "$r0r1" + | R2R3 -> "$r2r3" + | R4R5 -> "$r4r5" + | R6R7 -> "$r6r7" + | R8R9 -> "$r8r9" + | R10R11 -> "$r10r11" + | R12R13 -> "$r12r13" + | R14R15 -> "$r14r15" + | R16R17 -> "$r16r17" + | R18R19 -> "$r18r19" + | R20R21 -> "$r20r21" + | R22R23 -> "$r22r23" + | R24R25 -> "$r24r25" + | R26R27 -> "$r26r27" + | R28R29 -> "$r28r29" + | R30R31 -> "$r30r31" + | R32R33 -> "$r32r33" + | R34R35 -> "$r34r35" + | R36R37 -> "$r36r37" + | R38R39 -> "$r38r39" + | R40R41 -> "$r40r41" + | R42R43 -> "$r42r43" + | R44R45 -> "$r44r45" + | R46R47 -> "$r46r47" + | R48R49 -> "$r48r49" + | R50R51 -> "$r50r51" + | R52R53 -> "$r52r53" + | R54R55 -> "$r54r55" + | R56R57 -> "$r56r57" + | R58R59 -> "$r58r59" + | R60R61 -> "$r60r61" + | R62R63 -> "$r62r63" + + let int_gpreg_o_name = + let open Asmvliw in + function + | R0R1R2R3 -> "$r0r1r2r3" + | R4R5R6R7 -> "$r4r5r6r7" + | R8R9R10R11 -> "$r8r9r10r11" + | R12R13R14R15 -> "$r12r13r14r15" + | R16R17R18R19 -> "$r16r17r18r19" + | R20R21R22R23 -> "$r20r21r22r23" + | R24R25R26R27 -> "$r24r25r26r27" + | R28R29R30R31 -> "$r28r29r30r31" + | R32R33R34R35 -> "$r32r33r34r35" + | R36R37R38R39 -> "$r36r37r38r39" + | R40R41R42R43 -> "$r40r41r42r43" + | R44R45R46R47 -> "$r44r45r46r47" + | R48R49R50R51 -> "$r48r49r50r51" + | R52R53R54R55 -> "$r52r53r54r55" + | R56R57R58R59 -> "$r56r57r58r59" + | R60R61R62R63 -> "$r60r61r62r63";; + + let gpreg_q oc r = output_string oc (int_gpreg_q_name r) + let gpreg_o oc r = output_string oc (int_gpreg_o_name r) + + let preg oc = let open Asmvliw in function + | IR r -> ireg oc r + | RA -> output_string oc "$ra" + | _ -> assert false + + let preg_asm oc ty = preg oc + + let preg_annot = let open Asmvliw in function + | IR r -> int_reg_name r + | RA -> "$ra" + | _ -> assert false + + let scale_of_shift1_4 = let open ExtValues in function + | SHIFT1 -> 2 + | SHIFT2 -> 4 + | SHIFT3 -> 8 + | SHIFT4 -> 16;; + +(* Names of sections *) + + let name_of_section = function + | Section_text -> ".text" + | Section_data(true, true) -> + ".section .tdata,\"awT\",@progbits" + | Section_data(false, true) -> + ".section .tbss,\"awT\",@nobits" + | Section_data(i, false) | Section_small_data(i) -> + (if i then ".data" else "COMM") + | Section_const i | Section_small_const i -> + if i then ".section .rodata" else "COMM" + | Section_string -> ".section .rodata" + | Section_literal -> ".section .rodata" + | Section_jumptable -> ".section .rodata" + | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" + | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" + | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" + | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" + | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" + | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" + | Section_user(s, wr, ex) -> + sprintf ".section \"%s\",\"a%s%s\",%%progbits" + s (if wr then "w" else "") (if ex then "x" else "") + | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" + + let section oc sec = + fprintf oc " %s\n" (name_of_section sec) + +(* Associate labels to floating-point constants and to symbols. *) + + let print_tbl oc (lbl, tbl) = + fprintf oc " .balign 8\n"; + fprintf oc "%a:\n" label lbl; + List.iter + (fun l -> fprintf oc " .8byte %a\n" + print_label l) + tbl + + let emit_constants oc lit = + if exists_constants () then begin + section oc lit; + if Hashtbl.length literal64_labels > 0 then + begin + fprintf oc " .align 3\n"; + Hashtbl.iter + (fun bf lbl -> fprintf oc "%a: .quad 0x%Lx\n" label lbl bf) + literal64_labels + end; + if Hashtbl.length literal32_labels > 0 then + begin + fprintf oc " .align 2\n"; + Hashtbl.iter + (fun bf lbl -> + fprintf oc "%a: .long 0x%lx\n" label lbl bf) + literal32_labels + end; + reset_literals () + end + +(* Generate code to load the address of id + ofs in register r *) + + let loadsymbol oc r id ofs = + if Archi.pic_code () then begin + assert (ofs = Integers.Ptrofs.zero); + if C2C.atom_is_thread_local id then begin + (* fprintf oc " addd %a = $r13, @tprel(%s)\n" ireg r (extern_atom id) *) + fprintf oc " addd %a = $r13, @tlsle(%s)\n" ireg r (extern_atom id) + end else begin + fprintf oc " make %a = %s\n" ireg r (extern_atom id) + end + end else + begin + if C2C.atom_is_thread_local id then begin + (* fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) *) + fprintf oc " addd %a = $r13, @tlsle(%a)\n" ireg r symbol_offset (id, ofs) + end else begin + fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) + end + end + +(* Emit .file / .loc debugging directives *) + + let print_file_line oc file line = + print_file_line oc comment file line + +(* + let print_location oc loc = + if loc <> Cutil.no_loc then print_file_line oc (fst loc) (snd loc) +*) + +(* Add "w" suffix to 32-bit instructions if we are in 64-bit mode *) + + (*let w oc = + if Archi.ptr64 then output_string oc "w" + *) + + (* Profiling *) + + + let kvx_profiling_stub oc nr_items + profiling_id_table_name + profiling_counter_table_name = + fprintf oc " make $r0 = %d\n" nr_items; + fprintf oc " make $r1 = %s\n" profiling_id_table_name; + fprintf oc " make $r2 = %s\n" profiling_counter_table_name; + fprintf oc " goto %s\n" profiling_write_table_helper; + fprintf oc " ;;\n";; + + (* Offset part of a load or store *) + + let offset oc n = ptrofs oc n + + let addressing oc = function + | AOff ofs -> offset oc ofs + | AReg ro | ARegXS ro -> ireg oc ro + + let xscale oc = function + | ARegXS _ -> fprintf oc ".xs" + | _ -> () + + let lsvariant oc = function + | TRAP -> () + | NOTRAP -> output_string oc ".s" + + let icond_name = let open Asmvliw in function + | ITne | ITneu -> "ne" + | ITeq | ITequ -> "eq" + | ITlt -> "lt" + | ITge -> "ge" + | ITle -> "le" + | ITgt -> "gt" + | ITltu -> "ltu" + | ITgeu -> "geu" + | ITleu -> "leu" + | ITgtu -> "gtu" + + let icond oc c = fprintf oc "%s" (icond_name c) + + let fcond_name = let open Asmvliw in function + | FTone -> "one" + | FTueq -> "ueq" + | FToeq -> "oeq" + | FTune -> "une" + | FTolt -> "olt" + | FTuge -> "uge" + | FToge -> "oge" + | FTult -> "ult" + + let fcond oc c = fprintf oc "%s" (fcond_name c) + + let bcond_name = let open Asmvliw in function + | BTwnez -> "wnez" + | BTweqz -> "weqz" + | BTwltz -> "wltz" + | BTwgez -> "wgez" + | BTwlez -> "wlez" + | BTwgtz -> "wgtz" + | BTdnez -> "dnez" + | BTdeqz -> "deqz" + | BTdltz -> "dltz" + | BTdgez -> "dgez" + | BTdlez -> "dlez" + | BTdgtz -> "dgtz" + + let bcond oc c = fprintf oc "%s" (bcond_name c) + +(* Printing of instructions *) + exception ShouldBeExpanded + + let print_instruction oc = function + (* Pseudo-instructions expanded in Asmexpand *) + | Pallocframe(sz, ofs) -> assert false + | Pfreeframe(sz, ofs) -> assert false + + (* Pseudo-instructions that remain *) + | Plabel lbl -> + fprintf oc "%a:\n" print_label lbl + | Ploadsymbol(rd, id, ofs) -> + loadsymbol oc rd id ofs + | Pbuiltin(ef, args, res) -> + begin match ef with + | EF_annot(kind,txt, targs) -> + begin match (P.to_int kind) with + | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in + fprintf oc "%s annotation: %S\n" comment annot + (*| 2 -> let lbl = new_label () in + fprintf oc "%a: " label lbl; + add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args + *)| _ -> assert false + end + | EF_debug(kind, txt, targs) -> + print_debug_info comment print_file_line preg_annot "sp" oc + (P.to_int kind) (extern_atom txt) args + | EF_inline_asm(txt, sg, clob) -> + fprintf oc "%s begin inline assembly\n\t" comment; + print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; + fprintf oc "%s end inline assembly\n" comment + | EF_profiling(id, coq_kind) -> + let kind = Z.to_int coq_kind in + assert (kind >= 0); + assert (kind <= 1); + fprintf oc "%s profiling %a %d\n" comment + Profilingaux.pp_id id kind; + fprintf oc " make $r63 = %s\n" profiling_counter_table_name; + fprintf oc " make $r62 = 1\n"; + fprintf oc " ;;\n"; + fprintf oc " afaddd %d[$r63] = $r62\n" + (profiling_offset id kind); + fprintf oc " ;;\n" + | _ -> + assert false + end + | Pnop -> (* FIXME fprintf oc " nop\n" *) () + | Psemi -> fprintf oc ";;\n" + + | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs + | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + + + (* Control flow instructions *) + | Pget (rd, rs) -> + fprintf oc " get %a = %a\n" ireg rd preg rs + | Pset (rd, rs) -> + fprintf oc " set %a = %a\n" preg rd ireg rs + | Pret -> + fprintf oc " ret \n" + | Pcall(s) -> + fprintf oc " call %a\n" symbol s + | Picall(rs) -> + fprintf oc " icall %a\n" ireg rs + | Pgoto(s) -> + fprintf oc " goto %a\n" symbol s + | Pigoto(rs) -> + fprintf oc " igoto %a\n" ireg rs + | Pj_l(s) -> + fprintf oc " goto %a\n" print_label s + | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> + fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl + + (* For builtins *) + | Ploopdo (r, lbl) -> + fprintf oc " loopdo %a, %a\n" ireg r print_label lbl + | Pgetn(n, dst) -> + fprintf oc " get %a = $s%ld\n" ireg dst (camlint_of_coqint n) + | Psetn(n, dst) -> + fprintf oc " set $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pwfxl(n, dst) -> + fprintf oc " wfxl $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pwfxm(n, dst) -> + fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst + | Pldu(dst, addr) -> + fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr + | Plbzu(dst, addr) -> + fprintf oc " lbz.u %a = 0[%a]\n" ireg dst ireg addr + | Plhzu(dst, addr) -> + fprintf oc " lhz.u %a = 0[%a]\n" ireg dst ireg addr + | Plwzu(dst, addr) -> + fprintf oc " lwz.u %a = 0[%a]\n" ireg dst ireg addr + | Pawait -> + fprintf oc " await\n" + | Psleep -> + fprintf oc " sleep\n" + | Pstop -> + fprintf oc " stop\n" + | Pbarrier -> + fprintf oc " barrier\n" + | Pfence -> + fprintf oc " fence\n" + | Pdinval -> + fprintf oc " dinval\n" + | Pdinvall addr -> + fprintf oc " dinvall 0[%a]\n" ireg addr + | Pdtouchl addr -> + fprintf oc " dtouchl 0[%a]\n" ireg addr + | Piinval -> + fprintf oc " iinval\n" + | Piinvals addr -> + fprintf oc " iinvals 0[%a]\n" ireg addr + | Pitouchl addr -> + fprintf oc " itouchl 0[%a]\n" ireg addr + | Pdzerol addr -> + fprintf oc " dzerol 0[%a]\n" ireg addr +(* | Pafaddd(addr, incr_res) -> + fprintfoc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res + | Pafaddw(addr, incr_res) -> + fprintfoc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) + | Palclrd(res, addr) -> + fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr + | Palclrw(res, addr) -> + fprintf oc " alclrw %a = 0[%a]\n" ireg res ireg addr + | Pjumptable (idx_reg, tbl) -> + let lbl = new_label() in + (* jumptables := (lbl, tbl) :: !jumptables; *) + let base_reg = if idx_reg=Asmvliw.GPR63 then Asmvliw.GPR62 else Asmvliw.GPR63 in + fprintf oc "%s jumptable [ " comment; + List.iter (fun l -> fprintf oc "%a " print_label l) tbl; + fprintf oc "]\n"; + fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; + fprintf oc " ld.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; + fprintf oc " igoto %a\n ;;\n" ireg base_reg; + section oc Section_jumptable; + print_tbl oc (lbl, tbl); + section oc Section_text + + (* Load/Store instructions *) + | Plb(trap, rd, ra, adr) -> + fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plbu(trap, rd, ra, adr) -> + fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plh(trap, rd, ra, adr) -> + fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plhu(trap, rd, ra, adr) -> + fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) -> + fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra + | Plq(rd, ra, adr) -> + fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra + | Plo(rd, ra, adr) -> + fprintf oc " lo%a %a = %a[%a]\n" xscale adr gpreg_o rd addressing adr ireg ra + + | Psb(rd, ra, adr) -> + fprintf oc " sb%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd + | Psh(rd, ra, adr) -> + fprintf oc " sh%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd + | Psw(rd, ra, adr) | Psw_a(rd, ra, adr) | Pfss(rd, ra, adr) -> + fprintf oc " sw%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd + | Psd(rd, ra, adr) | Psd_a(rd, ra, adr) | Pfsd(rd, ra, adr) -> assert Archi.ptr64; + fprintf oc " sd%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd + | Psq(rd, ra, adr) -> + fprintf oc " sq%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_q rd + | Pso(rd, ra, adr) -> + fprintf oc " so%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_o rd + + (* Arith R instructions *) + + (* Arith RR instructions *) + | Pmv(rd, rs) -> + fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs + | Pcvtl2w(rd, rs) -> assert false + | Pnegl(rd, rs) -> assert Archi.ptr64; + fprintf oc " negd %a = %a\n" ireg rd ireg rs + | Pnegw(rd, rs) -> + fprintf oc " negw %a = %a\n" ireg rd ireg rs + | Psxwd(rd, rs) -> + fprintf oc " sxwd %a = %a\n" ireg rd ireg rs + | Pzxwd(rd, rs) -> + fprintf oc " zxwd %a = %a\n" ireg rd ireg rs + | Pextfz(rd, rs, stop, start) | Pextfzl(rd, rs, stop, start) -> + fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) + | Pextfs(rd, rs, stop, start) | Pextfsl(rd, rs, stop, start) -> + fprintf oc " extfs %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) + | Pinsf(rd, rs, stop, start) | Pinsfl(rd, rs, stop, start) -> + fprintf oc " insf %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) + | Pfabsd(rd, rs) -> + fprintf oc " fabsd %a = %a\n" ireg rd ireg rs + | Pfabsw(rd, rs) -> + fprintf oc " fabsw %a = %a\n" ireg rd ireg rs + | Pfnegd(rd, rs) -> + fprintf oc " fnegd %a = %a\n" ireg rd ireg rs + | Pfnegw(rd, rs) -> + fprintf oc " fnegw %a = %a\n" ireg rd ireg rs + | Pfnarrowdw(rd, rs) -> + fprintf oc " fnarrowdw %a = %a\n" ireg rd ireg rs + | Pfwidenlwd(rd, rs) -> + fprintf oc " fwidenlwd %a = %a\n" ireg rd ireg rs + | Pfloatuwrnsz(rd, rs) -> + fprintf oc " floatuw.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatwrnsz(rd, rs) -> + fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatudrnsz(rd, rs) -> + fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfloatdrnsz(rd, rs) -> + fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs + | Pfixedwrzz(rd, rs) -> + fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixeduwrzz(rd, rs) -> + fprintf oc " fixeduw.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixeddrzz(rd, rs) | Pfixeddrzz_i32(rd, rs) -> + fprintf oc " fixedd.rz %a = %a, 0\n" ireg rd ireg rs + | Pfixedudrzz(rd, rs) | Pfixedudrzz_i32(rd, rs) -> + fprintf oc " fixedud.rz %a = %a, 0\n" ireg rd ireg rs + + (* Arith RI32 instructions *) + | Pmake (rd, imm) -> + fprintf oc " make %a, %a\n" ireg rd coqint imm + + (* Arith RI64 instructions *) + | Pmakel (rd, imm) -> + fprintf oc " make %a, %a\n" ireg rd coqint64 imm + + (* Arith RF32 instructions *) + | Pmakefs (rd, f) -> + let d = Floats.Float32.to_bits f in + fprintf oc " make %a, %a %s %.18g\n" + ireg rd coqint d comment (camlfloat_of_coqfloat32 f) + + (* Arith RF64 instructions *) + | Pmakef (rd, f) -> + let d = Floats.Float.to_bits f in + fprintf oc " make %a, %a %s %.18g\n" + ireg rd coqint64 d comment (camlfloat_of_coqfloat f) + + (* Arith RRR instructions *) + | Pcompw (it, rd, rs1, rs2) -> + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 + | Pcompl (it, rd, rs1, rs2) -> + fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 + + | Pfcompw (ft, rd, rs1, rs2) -> + fprintf oc " fcompw.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 + | Pfcompl (ft, rd, rs1, rs2) -> + fprintf oc " fcompd.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 + + | Paddw (rd, rs1, rs2) -> + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxw (s14, rd, rs1, rs2) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 + | Psubw (rd, rs1, rs2) -> + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Prevsubxw (s14, rd, rs1, rs2) -> + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 + | Pmulw (rd, rs1, rs2) -> + fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pandw (rd, rs1, rs2) -> + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnandw (rd, rs1, rs2) -> + fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Porw (rd, rs1, rs2) -> + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnorw (rd, rs1, rs2) -> + fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pxorw (rd, rs1, rs2) -> + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnxorw (rd, rs1, rs2) -> + fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pandnw (rd, rs1, rs2) -> + fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pornw (rd, rs1, rs2) -> + fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psraw (rd, rs1, rs2) -> + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrxw (rd, rs1, rs2) -> + fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrlw (rd, rs1, rs2) -> + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psllw (rd, rs1, rs2) -> + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmaddw (rd, rs1, rs2) -> + fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmsubw (rd, rs1, rs2) -> + fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfw (rd, rs1, rs2) -> + fprintf oc " ffmaw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfw (rd, rs1, rs2) -> + fprintf oc " ffmsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + + | Paddl (rd, rs1, rs2) -> + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Paddxl (s14, rd, rs1, rs2) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 + | Psubl (rd, rs1, rs2) -> + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Prevsubxl (s14, rd, rs1, rs2) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs1 ireg rs2 + | Pandl (rd, rs1, rs2) -> + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnandl (rd, rs1, rs2) -> + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Porl (rd, rs1, rs2) -> + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnorl (rd, rs1, rs2) -> + fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pxorl (rd, rs1, rs2) -> + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pnxorl (rd, rs1, rs2) -> + fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pandnl (rd, rs1, rs2) -> + fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pornl (rd, rs1, rs2) -> + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmull (rd, rs1, rs2) -> + fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pslll (rd, rs1, rs2) -> + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrll (rd, rs1, rs2) -> + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psrxl (rd, rs1, rs2) -> + fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Psral (rd, rs1, rs2) -> + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmaddl (rd, rs1, rs2) -> + fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pmsubl (rd, rs1, rs2) -> + fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaddfl (rd, rs1, rs2) -> + fprintf oc " ffmad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmsubfl (rd, rs1, rs2) -> + fprintf oc " ffmsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + + | Pfaddd (rd, rs1, rs2) -> + fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfaddw (rd, rs1, rs2) -> + fprintf oc " faddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfsbfd (rd, rs1, rs2) -> + fprintf oc " fsbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Pfsbfw (rd, rs1, rs2) -> + fprintf oc " fsbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 + | Pfmuld (rd, rs1, rs2) -> + fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmulw (rd, rs1, rs2) -> + fprintf oc " fmulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmind (rd, rs1, rs2) -> + fprintf oc " fmind %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfminw (rd, rs1, rs2) -> + fprintf oc " fminw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxd (rd, rs1, rs2) -> + fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfmaxw (rd, rs1, rs2) -> + fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 + | Pfinvw (rd, rs1) -> + fprintf oc " finvw %a = %a\n" ireg rd ireg rs1 + + (* Arith RRI32 instructions *) + | Pcompiw (it, rd, rs, imm) -> + fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm + | Paddiw (rd, rs, imm) -> + fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Paddxiw (s14, rd, rs, imm) -> + fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm + | Prevsubiw (rd, rs, imm) -> + fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Prevsubxiw (s14, rd, rs, imm) -> + fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm + | Pmuliw (rd, rs, imm) -> + fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pandiw (rd, rs, imm) -> + fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnandiw (rd, rs, imm) -> + fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Poriw (rd, rs, imm) -> + fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnoriw (rd, rs, imm) -> + fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pxoriw (rd, rs, imm) -> + fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pnxoriw (rd, rs, imm) -> + fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pandniw (rd, rs, imm) -> + fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Porniw (rd, rs, imm) -> + fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psraiw (rd, rs, imm) -> + fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psrxiw (rd, rs, imm) -> + fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Psrliw (rd, rs, imm) -> + fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pslliw (rd, rs, imm) -> + fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Proriw (rd, rs, imm) -> + fprintf oc " rorw %a = %a, %a\n" ireg rd ireg rs coqint imm + | Pmaddiw (rd, rs, imm) -> + fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs coqint imm + + | Psllil (rd, rs, imm) -> + fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psrlil (rd, rs, imm) -> + fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psrail (rd, rs, imm) -> + fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Psrxil (rd, rs, imm) -> + fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + + (* Arith RRI64 instructions *) + | Pcompil (it, rd, rs, imm) -> + fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm + | Paddil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Paddxil (s14, rd, rs, imm) -> + fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint imm + | Prevsubil (rd, rs, imm) -> + fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Prevsubxil (s14, rd, rs, imm) -> + fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) + ireg rd ireg rs coqint64 imm + | Pmulil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnandil (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Poril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; + fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pandnil (rd, rs, imm) -> + fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pornil (rd, rs, imm) -> + fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + | Pmaddil (rd, rs, imm) -> + fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm + + | Pcmove (bt, rd, rcond, rs) | Pcmoveu (bt, rd, rcond, rs) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd ireg rs + | Pcmoveiw (bt, rd, rcond, imm) | Pcmoveuiw (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint imm + | Pcmoveil (bt, rd, rcond, imm) | Pcmoveuil (bt, rd, rcond, imm) -> + fprintf oc " cmoved.%a %a? %a = %a\n" + bcond bt ireg rcond ireg rd coqint64 imm + + let get_section_names name = + let (text, lit) = + match C2C.atom_sections name with + | t :: l :: _ -> (t, l) + | _ -> (Section_text, Section_literal) in + text,lit,Section_jumptable + + let print_align oc alignment = + fprintf oc " .balign %d\n" alignment + + let print_jumptable oc jmptbl = () + (* if !jumptables <> [] then + begin + section oc jmptbl; + List.iter (print_tbl oc) !jumptables; + jumptables := [] + end *) + + let print_fun_info = elf_print_fun_info + + let print_optional_fun_info _ = () + + let print_var_info = elf_print_var_info + + let print_comm_symb oc sz name align = + if C2C.atom_is_static name then + fprintf oc " .local %a\n" symbol name; + fprintf oc " .comm %a, %s, %d\n" + symbol name + (Z.to_string sz) + align + + let print_instructions oc fn = + current_function_sig := fn.fn_sig; + List.iter (print_instruction oc) fn.fn_code + +(* Data *) + + let address = if Archi.ptr64 then ".quad" else ".long" + + let print_prologue oc = + (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) + if !Clflags.option_g then begin + section oc Section_text; + end + + let print_epilogue oc = + print_profiling_epilogue elf_text_print_fun_info Dtors kvx_profiling_stub oc; + if !Clflags.option_g then begin + Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); + section oc Section_text; + end + + let default_falignment = 2 + + let cfi_startproc oc = () + let cfi_endproc oc = () + + end + +let sel_target () = + (module Target:TARGET) diff --git a/kvx/ValueAOp.v b/kvx/ValueAOp.v new file mode 100644 index 00000000..e634fdc0 --- /dev/null +++ b/kvx/ValueAOp.v @@ -0,0 +1,884 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib Compopts. +Require Import AST Integers Floats Values Memory Globalenvs. +Require Import Op ExtValues ExtFloats RTL ValueDomain. + +Definition intoffloat_total (x: aval) := + match x with + | F f => + match Float.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_int f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition intuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_intu f with + | Some i => I i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longoffloat_total (x: aval) := + match x with + | F f => + match Float.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuoffloat_total (x: aval) := + match x with + | F f => + match Float.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_long f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition longuofsingle_total (x: aval) := + match x with + | FS f => + match Float32.to_longu f with + | Some i => L i + | None => ntop + end + | _ => ntop1 x + end. + +Definition minf := binop_float ExtFloat.min. +Definition maxf := binop_float ExtFloat.max. +Definition minfs := binop_single ExtFloat32.min. +Definition maxfs := binop_single ExtFloat32.max. + +Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))). + +Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) := + match x, y, z with + | F a, F b, F c => F (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) := + match x, y, z with + | FS a, FS b, FS c => FS (sem a b c) + | _, _, _ => ntop3 x y z + end. + +Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x). +Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x). +Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x). +Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x). + +Definition invfs (y : aval) := + match y with + | FS f => FS (ExtFloat32.inv f) + | _ => ntop1 y + end. + +(** Value analysis for RISC V operators *) + +Definition eval_static_condition (cond: condition) (vl: list aval): abool := + match cond, vl with + | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 + | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 + | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) + | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) + | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 + | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 + | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) + | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) + | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 + | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) + | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 + | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) + | _, _ => Bnone + end. + +Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := + match addr, vl with + | Aindexed n, v1::nil => offset_ptr v1 n + | Aindexed2, v1::v2::nil => addl v1 v2 + | Aindexed2XS scale, v1::v2::nil => addl v1 (shll v2 (I (Int.repr scale))) + | Aglobal s ofs, nil => Ptr (Gl s ofs) + | Ainstack ofs, nil => Ptr (Stk ofs) + | _, _ => Vbot + end. + +Definition eval_static_condition0 (cond : condition0) (v : aval) : abool := + match cond with + | Ccomp0 c => cmp_bool c v (I Int.zero) + | Ccompu0 c => cmpu_bool c v (I Int.zero) + | Ccompl0 c => cmpl_bool c v (L Int64.zero) + | Ccomplu0 c => cmplu_bool c v (L Int64.zero) + end. + + +Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := + if is_bitfield stop start + then + let stop' := Z.add stop Z.one in + match v with + | I w => + I (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + +Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := + if is_bitfield stop start + then + let stop' := Z.add stop Z.one in + match v with + | I w => + I (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + +Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) := + if is_bitfieldl stop start + then + let stop' := Z.add stop Z.one in + match v with + | L w => + L (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + +Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) := + if is_bitfieldl stop start + then + let stop' := Z.add stop Z.one in + match v with + | L w => + L (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) + | _ => Vtop + end + else Vtop. + +Definition eval_static_insf stop start prev fld := + let mask := Int.repr (zbitfield_mask stop start) in + if is_bitfield stop start + then + match prev, fld with + | (I prevI), (I fldI) => + if Int.ltu (Int.repr start) Int.iwordsize + then I (Int.or (Int.and prevI (Int.not mask)) + (Int.and (Int.shl fldI (Int.repr start)) mask)) + else Vtop + | _, _ => Vtop + end + else Vtop. + +Definition eval_static_insfl stop start prev fld := + let mask := Int64.repr (zbitfield_mask stop start) in + if is_bitfieldl stop start + then + match prev, fld with + | (L prevL), (L fldL) => + if Int.ltu (Int.repr start) Int64.iwordsize' + then L (Int64.or (Int64.and prevL (Int64.not mask)) + (Int64.and (Int64.shl' fldL (Int.repr start)) mask)) + else Vtop + | _,_ => Vtop + end + else Vtop. + +Definition eval_static_operation (op: operation) (vl: list aval): aval := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Olongconst n, nil => L n + | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop + | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop + | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs) + | Oaddrstack ofs, nil => Ptr (Stk ofs) + | Ocast8signed, v1 :: nil => sign_ext 8 v1 + | Ocast16signed, v1 :: nil => sign_ext 16 v1 + | Oadd, v1::v2::nil => add v1 v2 + | Oaddimm n, v1::nil => add v1 (I n) + | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift))) + | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift))) + | Oneg, v1::nil => neg v1 + | Osub, v1::v2::nil => sub v1 v2 + | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift))) + | Orevsubimm n, v1::nil => sub (I n) v1 + | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift))) + | Omul, v1::v2::nil => mul v1 v2 + | Omulimm n, v1::nil => mul v1 (I n) + | Omulhs, v1::v2::nil => mulhs v1 v2 + | Omulhu, v1::v2::nil => mulhu v1 v2 + | Odiv, v1::v2::nil => divs v1 v2 + | Odivu, v1::v2::nil => divu v1 v2 + | Omod, v1::v2::nil => mods v1 v2 + | Omodu, v1::v2::nil => modu v1 v2 + | Oand, v1::v2::nil => and v1 v2 + | Oandimm n, v1::nil => and v1 (I n) + | Onand, v1::v2::nil => notint (and v1 v2) + | Onandimm n, v1::nil => notint (and v1 (I n)) + | Oor, v1::v2::nil => or v1 v2 + | Oorimm n, v1::nil => or v1 (I n) + | Onor, v1::v2::nil => notint (or v1 v2) + | Onorimm n, v1::nil => notint (or v1 (I n)) + | Oxor, v1::v2::nil => xor v1 v2 + | Oxorimm n, v1::nil => xor v1 (I n) + | Onxor, v1::v2::nil => notint (xor v1 v2) + | Onxorimm n, v1::nil => notint (xor v1 (I n)) + | Onot, v1::nil => notint v1 + | Oandn, v1::v2::nil => and (notint v1) v2 + | Oandnimm n, v1::nil => and (notint v1) (I n) + | Oorn, v1::v2::nil => or (notint v1) v2 + | Oornimm n, v1::nil => or (notint v1) (I n) + | Oshl, v1::v2::nil => shl v1 v2 + | Oshlimm n, v1::nil => shl v1 (I n) + | Oshr, v1::v2::nil => shr v1 v2 + | Oshrimm n, v1::nil => shr v1 (I n) + | Ororimm n, v1::nil => ror v1 (I n) + | Oshru, v1::v2::nil => shru v1 v2 + | Oshruimm n, v1::nil => shru v1 (I n) + | Oshrximm n, v1::nil => shrx v1 (I n) + | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3) + | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n)) + | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3) + | Omakelong, v1::v2::nil => longofwords v1 v2 + | Olowlong, v1::nil => loword v1 + | Ohighlong, v1::nil => hiword v1 + | Ocast32signed, v1::nil => longofint v1 + | Ocast32unsigned, v1::nil => longofintu v1 + | Oaddl, v1::v2::nil => addl v1 v2 + | Oaddlimm n, v1::nil => addl v1 (L n) + | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift))) + | Onegl, v1::nil => negl v1 + | Osubl, v1::v2::nil => subl v1 v2 + | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift))) + | Orevsublimm n, v1::nil => subl (L n) v1 + | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift))) + | Omull, v1::v2::nil => mull v1 v2 + | Omullimm n, v1::nil => mull v1 (L n) + | Omullhs, v1::v2::nil => mullhs v1 v2 + | Omullhu, v1::v2::nil => mullhu v1 v2 + | Odivl, v1::v2::nil => divls v1 v2 + | Odivlu, v1::v2::nil => divlu v1 v2 + | Omodl, v1::v2::nil => modls v1 v2 + | Omodlu, v1::v2::nil => modlu v1 v2 + | Oandl, v1::v2::nil => andl v1 v2 + | Oandlimm n, v1::nil => andl v1 (L n) + | Onandl, v1::v2::nil => notl (andl v1 v2) + | Onandlimm n, v1::nil => notl (andl v1 (L n)) + | Oorl, v1::v2::nil => orl v1 v2 + | Oorlimm n, v1::nil => orl v1 (L n) + | Onorl, v1::v2::nil => notl (orl v1 v2) + | Onorlimm n, v1::nil => notl (orl v1 (L n)) + | Oxorl, v1::v2::nil => xorl v1 v2 + | Oxorlimm n, v1::nil => xorl v1 (L n) + | Onxorl, v1::v2::nil => notl (xorl v1 v2) + | Onxorlimm n, v1::nil => notl (xorl v1 (L n)) + | Onotl, v1::nil => notl v1 + | Oandnl, v1::v2::nil => andl (notl v1) v2 + | Oandnlimm n, v1::nil => andl (notl v1) (L n) + | Oornl, v1::v2::nil => orl (notl v1) v2 + | Oornlimm n, v1::nil => orl (notl v1) (L n) + | Oshll, v1::v2::nil => shll v1 v2 + | Oshllimm n, v1::nil => shll v1 (I n) + | Oshrl, v1::v2::nil => shrl v1 v2 + | Oshrlimm n, v1::nil => shrl v1 (I n) + | Oshrlu, v1::v2::nil => shrlu v1 v2 + | Oshrluimm n, v1::nil => shrlu v1 (I n) + | Oshrxlimm n, v1::nil => shrxl v1 (I n) + | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3) + | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n)) + | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3) + | Onegf, v1::nil => negf v1 + | Oabsf, v1::nil => absf v1 + | Oaddf, v1::v2::nil => addf v1 v2 + | Osubf, v1::v2::nil => subf v1 v2 + | Omulf, v1::v2::nil => mulf v1 v2 + | Odivf, v1::v2::nil => divf v1 v2 + | Ominf, v1::v2::nil => minf v1 v2 + | Omaxf, v1::v2::nil => maxf v1 v2 + | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3 + | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3 + | Onegfs, v1::nil => negfs v1 + | Oabsfs, v1::nil => absfs v1 + | Oaddfs, v1::v2::nil => addfs v1 v2 + | Osubfs, v1::v2::nil => subfs v1 v2 + | Omulfs, v1::v2::nil => mulfs v1 v2 + | Odivfs, v1::v2::nil => divfs v1 v2 + | Ominfs, v1::v2::nil => minfs v1 v2 + | Omaxfs, v1::v2::nil => maxfs v1 v2 + | Oinvfs, v1::nil => invfs v1 + | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3 + | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3 + | Osingleoffloat, v1::nil => singleoffloat v1 + | Ofloatofsingle, v1::nil => floatofsingle v1 + | Ointoffloat, v1::nil => intoffloat_total v1 + | Ointuoffloat, v1::nil => intuoffloat_total v1 + | Ointofsingle, v1::nil => intofsingle_total v1 + | Ointuofsingle, v1::nil => intuofsingle_total v1 + | Osingleofint, v1::nil => singleofint v1 + | Osingleofintu, v1::nil => singleofintu v1 + | Olongoffloat, v1::nil => longoffloat_total v1 + | Olonguoffloat, v1::nil => longuoffloat_total v1 + | Ofloatoflong, v1::nil => floatoflong v1 + | Ofloatoflongu, v1::nil => floatoflongu v1 + | Olongofsingle, v1::nil => longofsingle_total v1 + | Olonguofsingle, v1::nil => longuofsingle_total v1 + | Osingleoflong, v1::nil => singleoflong v1 + | Osingleoflongu, v1::nil => singleoflongu v1 + | Ocmp c, _ => of_optbool (eval_static_condition c vl) + | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0 + | (Oextfs stop start), v0::nil => eval_static_extfs stop start v0 + | (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0 + | (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0 + | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 + | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 + | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 + | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) + | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) + | _, _ => Vbot + end. + +Section SOUNDNESS. + +Variable bc: block_classification. +Variable ge: genv. +Hypothesis GENV: genv_match bc ge. +Variable sp: block. +Hypothesis STACK: bc sp = BCstack. + +Lemma intoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intoffloat_total_sound : va. + +Lemma intuoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). +Proof. + unfold Val.intoffloat, intoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intuoffloat_total_sound : va. + +Lemma intofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intofsingle_total_sound : va. + +Lemma intuofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). +Proof. + unfold Val.intofsingle, intofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve intuofsingle_total_sound : va. + +Lemma singleofint_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleofint v)) (singleofint x). +Proof. + unfold Val.singleofint, singleofint; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleofint_total_sound : va. + +Lemma singleofintu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleofintu v)) (singleofintu x). +Proof. + unfold Val.singleofintu, singleofintu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleofintu_total_sound : va. + +Lemma longoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longoffloat_total_sound : va. + +Lemma longuoffloat_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). +Proof. + unfold Val.longoffloat, longoffloat_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longuoffloat_total_sound : va. + +Lemma longofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longofsingle_total_sound : va. + +Lemma longuofsingle_total_sound: + forall v x + (MATCH : vmatch bc v x), + vmatch bc (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). +Proof. + unfold Val.longofsingle, longofsingle_total. intros. + inv MATCH; simpl in *; try constructor. + all: destruct (Float32.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. + unfold ntop1, provenance. + destruct (va_strict tt); constructor. +Qed. + +Hint Resolve longuofsingle_total_sound : va. + +Lemma singleoflong_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleoflong v)) (singleoflong x). +Proof. + unfold Val.singleoflong, singleoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleoflong_total_sound : va. + +Lemma singleoflongu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). +Proof. + unfold Val.singleoflongu, singleoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve singleoflongu_total_sound : va. + +Lemma floatoflong_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.floatoflong v)) (floatoflong x). +Proof. + unfold Val.floatoflong, floatoflong; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve floatoflong_total_sound : va. + +Lemma floatoflongu_total_sound: + forall v x, vmatch bc v x -> + vmatch bc (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). +Proof. + unfold Val.floatoflongu, floatoflongu; intros. + inv H; simpl. + all: auto with va. + all: unfold ntop1, provenance. + all: try constructor. +Qed. + +Hint Resolve floatoflongu_total_sound : va. + +Lemma minf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). +Proof. + apply (binop_float_sound bc ExtFloat.min); assumption. +Qed. + +Lemma maxf_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y). +Proof. + apply (binop_float_sound bc ExtFloat.max); assumption. +Qed. + +Lemma minfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.min); assumption. +Qed. + +Lemma maxfs_sound: + forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y). +Proof. + apply (binop_single_sound bc ExtFloat32.max); assumption. +Qed. + +Lemma invfs_sound: + forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x). +Proof. + intros v x; + intro MATCH; + inversion MATCH; + simpl; + constructor. +Qed. + +Lemma triple_op_float_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_float f a b c) + (triple_op_float f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma triple_op_single_sound: + forall f a x b y c z, + vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.triple_op_single f a b c) + (triple_op_single f x y z). +Proof. + intros until z. + intros Hax Hby Hcz. + inv Hax; simpl; try constructor; + inv Hby; simpl; try constructor; + inv Hcz; simpl; try constructor. +Qed. + +Lemma fmaddf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z). +Proof. + intros. unfold ExtValues.fmaddf, fmaddf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmaddfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z). +Proof. + intros. unfold ExtValues.fmaddfs, fmaddfs. + apply triple_op_single_sound; assumption. +Qed. + +Lemma fmsubf_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z). +Proof. + intros. unfold ExtValues.fmsubf, fmsubf. + apply triple_op_float_sound; assumption. +Qed. + +Lemma fmsubfs_sound : + forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> + vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z). +Proof. + intros. unfold ExtValues.fmsubfs, fmsubfs. + apply triple_op_single_sound; assumption. +Qed. +Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va. + +Theorem eval_static_condition_sound: + forall cond vargs m aargs, + list_forall2 (vmatch bc) vargs aargs -> + cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). +Proof. + intros until aargs; intros VM. inv VM. + destruct cond; auto with va. + inv H0. + destruct cond; simpl; eauto with va. + inv H2. + destruct cond; simpl; eauto with va. + destruct cond; auto with va. +Qed. + +Theorem eval_static_condition0_sound: + forall cond varg m aarg, + vmatch bc varg aarg -> + cmatch (eval_condition0 cond varg m) (eval_static_condition0 cond aarg). +Proof. + intros until aarg; intro VM. + destruct cond; simpl; eauto with va. +Qed. + +Lemma symbol_address_sound: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). +Proof. + intros; apply symbol_address_sound; apply GENV. +Qed. + +Lemma symbol_address_sound_2: + forall id ofs, + vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). +Proof. + intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. + constructor. constructor. apply GENV; auto. + constructor. +Qed. + +Hint Resolve symbol_address_sound symbol_address_sound_2: va. + +Ltac InvHyps := + match goal with + | [H: None = Some _ |- _ ] => discriminate + | [H: Some _ = Some _ |- _] => inv H + | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , + H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps + | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps + | _ => idtac + end. + +Theorem eval_static_addressing_sound: + forall addr vargs vres aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_addressing addr aargs). +Proof. + unfold eval_addressing, eval_static_addressing; intros; + destruct addr; InvHyps; eauto with va. + rewrite Ptrofs.add_zero_l; eauto with va. +Qed. + +Theorem eval_static_addressing_sound_none: + forall addr vargs aargs, + eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> + list_forall2 (vmatch bc) vargs aargs -> + (eval_static_addressing addr aargs) = Vbot. +Proof. + unfold eval_addressing, eval_static_addressing. + intros until aargs. intros Heval_none Hlist. + inv Hlist. + destruct addr; trivial; discriminate. + inv H0. + destruct addr; trivial; discriminate. + inv H2. + destruct addr; trivial; discriminate. + inv H3; + destruct addr; trivial; discriminate. +Qed. + +Lemma vmatch_vint_ntop1: + forall x y, vmatch bc (Vint x) (ntop1 y). +Proof. + intro. unfold ntop1, provenance. + destruct y; + destruct (va_strict tt); + constructor. +Qed. + +Lemma vmatch_vlong_ntop1: + forall x y, vmatch bc (Vlong x) (ntop1 y). +Proof. + intro. unfold ntop1, provenance. + destruct y; + destruct (va_strict tt); + constructor. +Qed. + +Hint Resolve vmatch_vint_ntop1 vmatch_vlong_ntop1: va. + +Theorem eval_static_operation_sound: + forall op vargs m vres aargs, + eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> + list_forall2 (vmatch bc) vargs aargs -> + vmatch bc vres (eval_static_operation op aargs). +Proof. + unfold eval_operation, eval_static_operation, addx, revsubx, addxl, revsubxl; intros. + destruct op; InvHyps; eauto with va. + - destruct (propagate_float_constants tt); constructor. + - destruct (propagate_float_constants tt); constructor. + - rewrite Ptrofs.add_zero_l; eauto with va. + - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vundef + else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n)) + | _ => Vundef + end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - (*revsubimm*) inv H1; constructor. + - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with + | Vint n2 => Vint (Int.sub n n2) + | _ => Vundef + end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct n; destruct shift; reflexivity. + - (* shrx *) + inv H1; simpl; try constructor. + all: destruct Int.ltu; [simpl | constructor; fail]. + all: auto with va. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.add n n2) + | Vptr b2 ofs2 => + if Archi.ptr64 + then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) + else Vundef + | _ => Vundef + end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - inv H1; constructor. + - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with + | Vlong n2 => Vlong (Int64.sub n n2) + | _ => Vundef + end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). + + eauto with va. + + destruct a1; destruct shift; reflexivity. + - (* shrxl *) + inv H1; simpl; try constructor. + all: destruct Int.ltu; [simpl | constructor; fail]. + all: auto with va. + - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. + + (* extfz *) + - unfold extfz, eval_static_extfz. + destruct (is_bitfield _ _). + + inv H1; constructor. + + constructor. + + (* extfs *) + - unfold extfs, eval_static_extfs. + destruct (is_bitfield _ _). + + inv H1; constructor. + + constructor. + + (* extfzl *) + - unfold extfzl, eval_static_extfzl. + destruct (is_bitfieldl _ _). + + inv H1; constructor. + + constructor. + + (* extfsl *) + - unfold extfsl, eval_static_extfsl. + destruct (is_bitfieldl _ _). + + inv H1; constructor. + + constructor. + + (* insf *) + - unfold insf, eval_static_insf. + destruct (is_bitfield _ _). + + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + + constructor. + (* insfl *) + - unfold insfl, eval_static_insfl. + destruct (is_bitfieldl _ _). + + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. + + constructor. + (* select *) + - apply select_sound; auto. eapply eval_static_condition0_sound; eauto. + (* select imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. + (* select long imm *) + - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. +Qed. + +End SOUNDNESS. + diff --git a/kvx/abstractbb/AbstractBasicBlocksDef.v b/kvx/abstractbb/AbstractBasicBlocksDef.v new file mode 100644 index 00000000..0b1c502d --- /dev/null +++ b/kvx/abstractbb/AbstractBasicBlocksDef.v @@ -0,0 +1,452 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Syntax and Sequential Semantics of Abstract Basic Blocks. +*) +Require Import Setoid. +Require Import ImpPrelude. + +Module Type PseudoRegisters. + +Parameter t: Type. + +Parameter eq_dec: forall (x y: t), { x = y } + { x<>y }. + +End PseudoRegisters. + + +(** * Parameters of the language of Basic Blocks *) +Module Type LangParam. + +Declare Module R: PseudoRegisters. + +Parameter value: Type. + +(** Declare the type of operations *) + +Parameter op: Type. (* type of operations *) + +Parameter genv: Type. (* environment to be used for evaluating an op *) + +Parameter op_eval: genv -> op -> list value -> option value. + +End LangParam. + + + +(** * Syntax and (sequential) semantics of "basic blocks" *) +Module MkSeqLanguage(P: LangParam). + +Export P. + +Local Open Scope list. + +Section SEQLANG. + +Variable ge: genv. + +Definition mem := R.t -> value. + +Definition assign (m: mem) (x:R.t) (v: value): mem + := fun y => if R.eq_dec x y then v else m y. + + +(** expressions *) + +Inductive exp := + | PReg (x:R.t) + | Op (o:op) (le: list_exp) + | Old (e: exp) +with list_exp := + | Enil + | Econs (e:exp) (le:list_exp) + | LOld (le: list_exp) +. + +Fixpoint exp_eval (e: exp) (m old: mem): option value := + match e with + | PReg x => Some (m x) + | Op o le => + match list_exp_eval le m old with + | Some lv => op_eval ge o lv + | _ => None + end + | Old e => exp_eval e old old + end +with list_exp_eval (le: list_exp) (m old: mem): option (list value) := + match le with + | Enil => Some nil + | Econs e le' => + match exp_eval e m old, list_exp_eval le' m old with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + | LOld le => list_exp_eval le old old + end. + +Definition inst := list (R.t * exp). (* = a sequence of assignments *) + +Fixpoint inst_run (i: inst) (m old: mem): option mem := + match i with + | nil => Some m + | (x, e)::i' => + match exp_eval e m old with + | Some v' => inst_run i' (assign m x v') old + | None => None + end + end. + +Definition bblock := list inst. + +Fixpoint run (p: bblock) (m: mem): option mem := + match p with + | nil => Some m + | i::p' => + match inst_run i m m with + | Some m' => run p' m' + | None => None + end + end. + +(* A few useful lemma *) +Lemma assign_eq m x v: + (assign m x v) x = v. +Proof. + unfold assign. destruct (R.eq_dec x x); try congruence. +Qed. + +Lemma assign_diff m x y v: + x<>y -> (assign m x v) y = m y. +Proof. + unfold assign. destruct (R.eq_dec x y); try congruence. +Qed. + +Lemma assign_skips m x y: + (assign m x (m x)) y = m y. +Proof. + unfold assign. destruct (R.eq_dec x y); try congruence. +Qed. + +Lemma assign_swap m x1 v1 x2 v2 y: + x1 <> x2 -> (assign (assign m x1 v1) x2 v2) y = (assign (assign m x2 v2) x1 v1) y. +Proof. + intros; destruct (R.eq_dec x2 y). + - subst. rewrite assign_eq, assign_diff; auto. rewrite assign_eq; auto. + - rewrite assign_diff; auto. + destruct (R.eq_dec x1 y). + + subst; rewrite! assign_eq. auto. + + rewrite! assign_diff; auto. +Qed. + + +(** A small theory of bblock simulation *) + +(* equalities on bblock outputs *) +Definition res_eq (om1 om2: option mem): Prop := + match om1 with + | Some m1 => exists m2, om2 = Some m2 /\ forall x, m1 x = m2 x + | None => om2 = None + end. + +Scheme exp_mut := Induction for exp Sort Prop +with list_exp_mut := Induction for list_exp Sort Prop. + +Lemma exp_equiv e old1 old2: + (forall x, old1 x = old2 x) -> + forall m1 m2, (forall x, m1 x = m2 x) -> + (exp_eval e m1 old1) = (exp_eval e m2 old2). +Proof. + intros H1. + induction e using exp_mut with (P0:=fun l => forall m1 m2, (forall x, m1 x = m2 x) -> list_exp_eval l m1 old1 = list_exp_eval l m2 old2); simpl; try congruence; auto. + - intros; erewrite IHe; eauto. + - intros; erewrite IHe, IHe0; auto. +Qed. + +Definition bblock_simu (p1 p2: bblock): Prop + := forall m, (run p1 m) <> None -> res_eq (run p1 m) (run p2 m). + +Lemma inst_equiv_refl i old1 old2: + (forall x, old1 x = old2 x) -> + forall m1 m2, (forall x, m1 x = m2 x) -> + res_eq (inst_run i m1 old1) (inst_run i m2 old2). +Proof. + intro H; induction i as [ | [x e]]; simpl; eauto. + intros m1 m2 H1. erewrite exp_equiv; eauto. + destruct (exp_eval e m2 old2); simpl; auto. + apply IHi. + unfold assign; intro y. destruct (R.eq_dec x y); auto. +Qed. + +Lemma bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). +Proof. + induction p as [ | i p']; simpl; eauto. + intros m1 m2 H; lapply (inst_equiv_refl i m1 m2); auto. + intros X; lapply (X m1 m2); auto; clear X. + destruct (inst_run i m1 m1); simpl. + - intros [m3 [H1 H2]]; rewrite H1; simpl; auto. + - intros H1; rewrite H1; simpl; auto. +Qed. + +Lemma res_eq_sym om1 om2: res_eq om1 om2 -> res_eq om2 om1. +Proof. + destruct om1; simpl. + - intros [m2 [H1 H2]]; subst; simpl. eauto. + - intros; subst; simpl; eauto. +Qed. + +Lemma res_eq_trans (om1 om2 om3: option mem): + (res_eq om1 om2) -> (res_eq om2 om3) -> (res_eq om1 om3). +Proof. + destruct om1; simpl. + - intros [m2 [H1 H2]]; subst; simpl. + intros [m3 [H3 H4]]; subst; simpl. + eapply ex_intro; intuition eauto. rewrite H2; auto. + - intro; subst; simpl; auto. +Qed. + +Lemma bblock_simu_alt p1 p2: bblock_simu p1 p2 <-> (forall m1 m2, (forall x, m1 x = m2 x) -> (run p1 m1)<>None -> res_eq (run p1 m1) (run p2 m2)). +Proof. + unfold bblock_simu; intuition. + intros; eapply res_eq_trans. eauto. + eapply bblock_equiv_refl; eauto. +Qed. + + +Lemma run_app p1: forall m1 p2, + run (p1++p2) m1 = + match run p1 m1 with + | Some m2 => run p2 m2 + | None => None + end. +Proof. + induction p1; simpl; try congruence. + intros; destruct (inst_run _ _ _); simpl; auto. +Qed. + +Lemma run_app_None p1 m1 p2: + run p1 m1 = None -> + run (p1++p2) m1 = None. +Proof. + intro H; rewrite run_app. rewrite H; auto. +Qed. + +Lemma run_app_Some p1 m1 m2 p2: + run p1 m1 = Some m2 -> + run (p1++p2) m1 = run p2 m2. +Proof. + intros H; rewrite run_app. rewrite H; auto. +Qed. + +End SEQLANG. + +Module Terms. + +(** terms in the symbolic evaluation +NB: such a term represents the successive computations in one given pseudo-register +*) + +Inductive term := + | Input (x:R.t) (hid:hashcode) + | App (o: op) (l: list_term) (hid:hashcode) +with list_term := + | LTnil (hid:hashcode) + | LTcons (t:term) (l:list_term) (hid:hashcode) + . + +Scheme term_mut := Induction for term Sort Prop +with list_term_mut := Induction for list_term Sort Prop. + +Bind Scope pattern_scope with term. +Delimit Scope term_scope with term. +Delimit Scope pattern_scope with pattern. + +Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope. +Notation "[ x ]" := (LTcons x [] _): pattern_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope. +Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope. + +Import HConsingDefs. + +Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope. +Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope. +Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope. +Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope. + +Local Open Scope pattern_scope. + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x _ => Some (m x) + | o @ l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | [] => Some nil + | LTcons t l' _ => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + + +Definition term_get_hid (t: term): hashcode := + match t with + | Input _ hid => hid + | App _ _ hid => hid + end. + +Definition list_term_get_hid (l: list_term): hashcode := + match l with + | LTnil hid => hid + | LTcons _ _ hid => hid + end. + + +Fixpoint allvalid ge (l: list term) m : Prop := + match l with + | nil => True + | t::nil => term_eval ge t m <> None + | t::l' => term_eval ge t m <> None /\ allvalid ge l' m + end. + +Lemma allvalid_extensionality ge (l: list term) m: + allvalid ge l m <-> (forall t, List.In t l -> term_eval ge t m <> None). +Proof. + induction l as [|t l]; simpl; try (tauto). + destruct l. + - intuition (congruence || eauto). + - rewrite IHl; clear IHl. intuition (congruence || eauto). +Qed. + +Record pseudo_term: Type := intro_fail { + mayfail: list term; + effect: term +}. + +Lemma inf_option_equivalence (A:Type) (o1 o2: option A): + (o1 <> None -> o1 = o2) <-> (forall m1, o1 = Some m1 -> o2 = Some m1). +Proof. + destruct o1; intuition (congruence || eauto). + symmetry; eauto. +Qed. + +Definition match_pt (t: term) (pt: pseudo_term) := + (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) + /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). + +Lemma intro_fail_correct (l: list term) (t: term) : + (forall ge m, term_eval ge t m <> None <-> allvalid ge l m) -> match_pt t (intro_fail l t). +Proof. + unfold match_pt; simpl; intros; intuition congruence. +Qed. +Hint Resolve intro_fail_correct: wlp. + +Definition identity_fail (t: term):= intro_fail [t] t. + +Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). +Proof. + eapply intro_fail_correct; simpl; tauto. +Qed. +Global Opaque identity_fail. +Hint Resolve identity_fail_correct: wlp. + +Definition nofail (is_constant: op -> bool) (t: term):= + match t with + | Input x _ => intro_fail ([])%list t + | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t) + | _ => identity_fail t + end. + +Lemma nofail_correct (is_constant: op -> bool) t: + (forall ge o, is_constant o = true -> op_eval ge o nil <> None) -> match_pt t (nofail is_constant t). +Proof. + destruct t; simpl. + + intros; eapply intro_fail_correct; simpl; intuition congruence. + + intros; destruct l; simpl; auto with wlp. + destruct (is_constant o) eqn:Heqo; simpl; intuition eauto with wlp. + eapply intro_fail_correct; simpl; intuition eauto with wlp. +Qed. +Global Opaque nofail. +Hint Resolve nofail_correct: wlp. + +Definition term_equiv t1 t2:= forall ge m, term_eval ge t1 m = term_eval ge t2 m. + +Global Instance term_equiv_Equivalence : Equivalence term_equiv. +Proof. + split; intro x; unfold term_equiv; intros; eauto. + eapply eq_trans; eauto. +Qed. + +Lemma match_pt_term_equiv t1 t2 pt: term_equiv t1 t2 -> match_pt t1 pt -> match_pt t2 pt. +Proof. + unfold match_pt, term_equiv. + intros H. intuition; try (erewrite <- H1 in * |- *; congruence). + erewrite <- H2; eauto; congruence. +Qed. +Hint Resolve match_pt_term_equiv: wlp. + +Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term := + {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}. + +Lemma app_fail_allvalid_correct l pt t1 t2: forall + (V1: forall (ge : genv) (m : mem), term_eval ge t1 m <> None <-> allvalid ge (mayfail pt) m) + (V2: forall (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail {| mayfail := t1 :: l; effect := t1 |}) m) + (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail (app_fail l pt)) m. +Proof. + intros; generalize (V1 ge m) (V2 ge m); rewrite !allvalid_extensionality; simpl. clear V1 V2. + intuition subst. + + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto. + + eapply H3; eauto. + intros. intuition subst. + * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. + * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. +Qed. +Local Hint Resolve app_fail_allvalid_correct: core. + +Lemma app_fail_correct l pt t1 t2: + match_pt t1 pt -> + match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> + match_pt t2 (app_fail l pt). +Proof. + unfold match_pt in * |- *; intros (V1 & E1) (V2 & E2); split; intros ge m; try (eauto; fail). +Qed. +Extraction Inline app_fail. + +Import ImpCore.Notations. +Local Open Scope impure_scope. + +Record reduction:= { + result:> term -> ?? pseudo_term; + result_correct: forall t, WHEN result t ~> pt THEN match_pt t pt; +}. +Hint Resolve result_correct: wlp. + +End Terms. + +End MkSeqLanguage. + + +Module Type SeqLanguage. + +Declare Module LP: LangParam. + +Include MkSeqLanguage LP. + +End SeqLanguage. + diff --git a/kvx/abstractbb/ImpSimuTest.v b/kvx/abstractbb/ImpSimuTest.v new file mode 100644 index 00000000..c914eee1 --- /dev/null +++ b/kvx/abstractbb/ImpSimuTest.v @@ -0,0 +1,1258 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks + +with imperative hash-consing, and rewriting. + +*) + +Require Export Impure.ImpHCons. +Export Notations. +Import HConsing. + + +Require Export SeqSimuTheory. + +Require Import PArith. + + +Local Open Scope impure. + +Import ListNotations. +Local Open Scope list_scope. + + +Module Type ImpParam. + +Include LangParam. + +Parameter op_eq: op -> op -> ?? bool. + +Parameter op_eq_correct: forall o1 o2, + WHEN op_eq o1 o2 ~> b THEN + b=true -> o1 = o2. + +End ImpParam. + + +Module Type ISeqLanguage. + +Declare Module LP: ImpParam. + +Include MkSeqLanguage LP. + +End ISeqLanguage. + + +Module Type ImpDict. + +Declare Module R: PseudoRegisters. + +Parameter t: Type -> Type. + +Parameter get: forall {A}, t A -> R.t -> option A. + +Parameter set: forall {A}, t A -> R.t -> A -> t A. + +Parameter set_spec_eq: forall A d x (v: A), + get (set d x v) x = Some v. + +Parameter set_spec_diff: forall A d x y (v: A), + x <> y -> get (set d x v) y = get d y. + +Parameter rem: forall {A}, t A -> R.t -> t A. + +Parameter rem_spec_eq: forall A (d: t A) x, + get (rem d x) x = None. + +Parameter rem_spec_diff: forall A (d: t A) x y, + x <> y -> get (rem d x) y = get d y. + +Parameter empty: forall {A}, t A. + +Parameter empty_spec: forall A x, + get (empty (A:=A)) x = None. + +Parameter eq_test: forall {A}, t A -> t A -> ?? bool. + +Parameter eq_test_correct: forall A (d1 d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. + +(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) + + +(* only for debugging *) +Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. + +End ImpDict. + + +Module Type ImpSimuInterface. + +Declare Module CoreL: ISeqLanguage. +Import CoreL. +Import Terms. + +Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool. + +Parameter bblock_simu_test_correct: forall reduce (p1 p2 : bblock), + WHEN bblock_simu_test reduce p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + + +Parameter verb_bblock_simu_test + : reduction -> + (R.t -> ?? pstring) -> + (op -> ?? pstring) -> bblock -> bblock -> ?? bool. + +Parameter verb_bblock_simu_test_correct: + forall reduce + (string_of_name : R.t -> ?? pstring) + (string_of_op : op -> ?? pstring) + (p1 p2 : bblock), + WHEN verb_bblock_simu_test reduce string_of_name string_of_op p1 p2 ~> b + THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. + +End ImpSimuInterface. + + + +Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuInterface with Module CoreL := L. + +Module CoreL:=L. + +Module ST := SimuTheory L. + +Import ST. +Import Terms. + +Definition term_set_hid (t: term) (hid: hashcode): term := + match t with + | Input x _ => Input x hid + | App op l _ => App op l hid + end. + +Definition list_term_set_hid (l: list_term) (hid: hashcode): list_term := + match l with + | LTnil _ => LTnil hid + | LTcons t l' _ => LTcons t l' hid + end. + +Lemma term_eval_set_hid ge t hid m: + term_eval ge (term_set_hid t hid) m = term_eval ge t m. +Proof. + destruct t; simpl; auto. +Qed. + +Lemma list_term_eval_set_hid ge l hid m: + list_term_eval ge (list_term_set_hid l hid) m = list_term_eval ge l m. +Proof. + destruct l; simpl; auto. +Qed. + +(* Local nickname *) +Module D:=ImpPrelude.Dict. + +Section SimuWithReduce. + +Variable reduce: reduction. + +Section CanonBuilding. + +Variable hC_term: hashinfo term -> ?? term. +Hypothesis hC_term_correct: forall t, WHEN hC_term t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hC_list_term: hashinfo list_term -> ?? list_term. +Hypothesis hC_list_term_correct: forall t, WHEN hC_list_term t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +(* First, we wrap constructors for hashed values !*) + +Local Open Scope positive. +Local Open Scope list_scope. + +Definition hInput_hcodes (x:R.t) := + DO hc <~ hash 1;; + DO hv <~ hash x;; + RET [hc;hv]. +Extraction Inline hInput_hcodes. + +Definition hInput (x:R.t): ?? term := + DO hv <~ hInput_hcodes x;; + hC_term {| hdata:=Input x unknown_hid; hcodes :=hv; |}. + +Lemma hInput_correct x: + WHEN hInput x ~> t THEN forall ge m, term_eval ge t m = Some (m x). +Proof. + wlp_simplify. +Qed. +Global Opaque hInput. +Hint Resolve hInput_correct: wlp. + +Definition hApp_hcodes (o:op) (l: list_term) := + DO hc <~ hash 2;; + DO hv <~ hash o;; + RET [hc;hv;list_term_get_hid l]. +Extraction Inline hApp_hcodes. + +Definition hApp (o:op) (l: list_term) : ?? term := + DO hv <~ hApp_hcodes o l;; + hC_term {| hdata:=App o l unknown_hid; hcodes:=hv |}. + +Lemma hApp_correct o l: + WHEN hApp o l ~> t THEN forall ge m, + term_eval ge t m = match list_term_eval ge l m with + | Some v => op_eval ge o v + | None => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hApp. +Hint Resolve hApp_correct: wlp. + +Definition hLTnil (_: unit): ?? list_term := + hC_list_term {| hdata:=LTnil unknown_hid; hcodes := nil; |} . + +Lemma hLTnil_correct x: + WHEN hLTnil x ~> l THEN forall ge m, list_term_eval ge l m = Some nil. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTnil. +Hint Resolve hLTnil_correct: wlp. + + +Definition hLTcons (t: term) (l: list_term): ?? list_term := + hC_list_term {| hdata:=LTcons t l unknown_hid; hcodes := [term_get_hid t; list_term_get_hid l]; |}. + +Lemma hLTcons_correct t l: + WHEN hLTcons t l ~> l' THEN forall ge m, + list_term_eval ge l' m = match term_eval ge t m, list_term_eval ge l m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end. +Proof. + wlp_simplify. +Qed. +Global Opaque hLTcons. +Hint Resolve hLTcons_correct: wlp. + +(* Second, we use these hashed constructors ! *) + +Record hsmem:= {hpre: list term; hpost:> Dict.t term}. + +(** evaluation of the post-condition *) +Definition hsmem_post_eval ge (hd: Dict.t term) x (m:mem) := + match Dict.get hd x with + | None => Some (m x) + | Some ht => term_eval ge ht m + end. + +Definition hsmem_get (d:hsmem) x: ?? term := + match Dict.get d x with + | None => hInput x + | Some t => RET t + end. + +Lemma hsmem_get_correct (d:hsmem) x: + WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = hsmem_post_eval ge d x m. +Proof. + unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify. +Qed. +Global Opaque hsmem_get. +Hint Resolve hsmem_get_correct: wlp. + +Local Opaque allvalid. + +Definition smem_model ge (d: smem) (hd:hsmem): Prop := + (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) + /\ (forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m = (ST.term_eval ge (d x) m)). + +Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> + forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. rewrite H2; auto. + unfold smem_valid in H. intuition eauto. +Qed. + +Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> + forall m x, allvalid ge hd.(hpre) m -> hsmem_post_eval ge hd x m <> None. +Proof. + intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. + - split; eauto. + - rewrite <- H1; auto. +Qed. + +Definition naive_set (hd:hsmem) x (t:term) := + {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. + +Lemma naive_set_correct hd x ht ge d t: + smem_model ge d hd -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> + smem_model ge (smem_set d x t) (naive_set hd x ht). +Proof. + unfold naive_set; intros (DM0 & DM1) EQT; split. + - intros m. + destruct (DM0 m) as (PRE & VALID0); clear DM0. + assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } + assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, ST.term_eval ge (d x) m <> None). { unfold smem_valid in PRE; tauto. } + rewrite !allvalid_extensionality in * |- *; simpl. + intuition (subst; eauto). + + eapply smem_valid_set_proof; eauto. + erewrite <- EQT; eauto. + + exploit smem_valid_set_decompose_1; eauto. + intros X1; exploit smem_valid_set_decompose_2; eauto. + rewrite <- EQT; eauto. + + exploit smem_valid_set_decompose_1; eauto. + - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. + Local Hint Resolve smem_valid_set_decompose_1: core. + intros; case (R.eq_dec x x0). + + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. + + intros; rewrite !Dict.set_spec_diff; simpl; eauto. +Qed. +Local Hint Resolve naive_set_correct: core. + +Definition equiv_hsmem ge (hd1 hd2: hsmem) := + (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) + /\ (forall m x, allvalid ge hd1.(hpre) m -> hsmem_post_eval ge hd1 x m = hsmem_post_eval ge hd2 x m). + +Lemma equiv_smem_symmetry ge hd1 hd2: + equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1. +Proof. + intros (V1 & P1); split. + - intros; symmetry; auto. + - intros; symmetry; eapply P1. rewrite V1; auto. +Qed. + +Lemma equiv_hsmem_models ge hd1 hd2 d: + smem_model ge d hd1 -> equiv_hsmem ge hd1 hd2 -> smem_model ge d hd2. +Proof. + intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. + - intros m; rewrite <- VALID; auto. symmetry; auto. + - intros m x H. rewrite <- EQUIV; auto. + rewrite PEQUIV; auto. + rewrite VALID; auto. +Qed. + +Variable log_assign: R.t -> term -> ?? unit. + +Definition lift {A B} hid (x:A) (k: B -> ?? A) (y:B): ?? A := + DO b <~ phys_eq hid unknown_hid;; + if b then k y else RET x. + +Fixpoint hterm_lift (t: term): ?? term := + match t with + | Input x hid => lift hid t hInput x + | App o l hid => + lift hid t + (fun l => DO lt <~ hlist_term_lift l;; + hApp o lt) l + end +with hlist_term_lift (l: list_term) {struct l}: ?? list_term := + match l with + | LTnil hid => lift hid l hLTnil () + | LTcons t l' hid => + lift hid l + (fun t => DO t <~ hterm_lift t;; + DO lt <~ hlist_term_lift l';; + hLTcons t lt) t + end. + +Lemma hterm_lift_correct t: + WHEN hterm_lift t ~> ht THEN forall ge m, term_eval ge ht m = term_eval ge t m. +Proof. + induction t using term_mut with (P0:=fun lt => + WHEN hlist_term_lift lt ~> hlt THEN forall ge m, list_term_eval ge hlt m = list_term_eval ge lt m); + wlp_simplify. + - rewrite H0, H; auto. + - rewrite H1, H0, H; auto. +Qed. +Local Hint Resolve hterm_lift_correct: wlp. +Global Opaque hterm_lift. + +Variable log_new_hterm: term -> ?? unit. + +Fixpoint hterm_append (l: list term) (lh: list term): ?? list term := + match l with + | nil => RET lh + | t::l' => + DO ht <~ hterm_lift t;; + log_new_hterm ht;; + hterm_append l' (ht::lh) + end. + +Lemma hterm_append_correct l: forall lh, + WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)). +Proof. + Local Hint Resolve eq_trans: localhint. + induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). + - intros; rewrite! allvalid_extensionality; intuition eauto. + - intros REC ge m; rewrite REC; clear IHl' REC. rewrite !allvalid_extensionality. + simpl; intuition (subst; eauto with wlp localhint). +Qed. +(*Local Hint Resolve hterm_append_correct: wlp.*) +Global Opaque hterm_append. + +Definition smart_set (hd:hsmem) x (ht:term) := + match ht with + | Input y _ => + if R.eq_dec x y then + RET (Dict.rem hd x) + else ( + log_assign x ht;; + RET (Dict.set hd x ht) + ) + | _ => + log_assign x ht;; + RET (Dict.set hd x ht) + end. + +Lemma smart_set_correct hd x ht: + WHEN smart_set hd x ht ~> d THEN + forall ge m y, hsmem_post_eval ge d y m = hsmem_post_eval ge (Dict.set hd x ht) y m. +Proof. + destruct ht; wlp_simplify. + unfold hsmem_post_eval; simpl. case (R.eq_dec x0 y). + - intros; subst. rewrite Dict.set_spec_eq, Dict.rem_spec_eq. simpl; congruence. + - intros; rewrite Dict.set_spec_diff, Dict.rem_spec_diff; auto. +Qed. +(*Local Hint Resolve smart_set_correct: wlp.*) +Global Opaque smart_set. + +Definition hsmem_set (hd:hsmem) x (t:term) := + DO pt <~ reduce t;; + DO lht <~ hterm_append pt.(mayfail) hd.(hpre);; + DO ht <~ hterm_lift pt.(effect);; + log_new_hterm ht;; + DO nd <~ smart_set hd x ht;; + RET {| hpre := lht; hpost := nd |}. + +Lemma hsmem_set_correct hd x ht: + WHEN hsmem_set hd x ht ~> nhd THEN + forall ge d t, smem_model ge d hd -> + (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> + smem_model ge (smem_set d x t) nhd. +Proof. + intros; wlp_simplify. + generalize (hterm_append_correct _ _ _ Hexta0); intro APPEND. + generalize (hterm_lift_correct _ _ Hexta1); intro LIFT. + generalize (smart_set_correct _ _ _ _ Hexta3); intro SMART. + eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. + destruct H as (VALID & EFFECT); split. + - intros; rewrite APPEND, <- VALID. + rewrite !allvalid_extensionality in * |- *; simpl; intuition (subst; eauto). + - intros m x0 ALLVALID; rewrite SMART. + destruct (term_eval ge ht m) eqn: Hht. + * case (R.eq_dec x x0). + + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq. + erewrite LIFT, EFFECT; eauto. + + intros; unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_diff; auto. + * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. +Qed. +Local Hint Resolve hsmem_set_correct: wlp. +Global Opaque hsmem_set. + +(* VARIANTE: we do not hash-cons the term from the expression +Lemma exp_hterm_correct ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. +Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); + unfold smem_model in * |- * ; simpl; intuition eauto. + - erewrite IHe; eauto. + - erewrite IHe0, IHe; eauto. +Qed. +Local Hint Resolve exp_hterm_correct: wlp. +*) + +Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term := + match e with + | PReg x => hsmem_get hd x + | Op o le => + DO lt <~ list_exp_hterm le hd hod;; + hApp o lt + | Old e => exp_hterm e hod hod + end +with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term := + match le with + | Enil => hLTnil tt + | Econs e le' => + DO t <~ exp_hterm e hd hod;; + DO lt <~ list_exp_hterm le' hd hod;; + hLTcons t lt + | LOld le => list_exp_hterm le hod hod + end. + +Lemma exp_hterm_correct_x ge e hod od: + smem_model ge od hod -> + forall hd d, + smem_model ge d hd -> + WHEN exp_hterm e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. + Proof. + intro H. + induction e using exp_mut with (P0:=fun le => forall d hd, + smem_model ge d hd -> + WHEN list_exp_hterm le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = ST.list_term_eval ge (list_exp_term le d od) m); + unfold smem_model, hsmem_post_eval in * |- * ; simpl; wlp_simplify. + - rewrite H1, <- H4; auto. + - rewrite H4, <- H0; simpl; auto. + - rewrite H5, <- H0, <- H4; simpl; auto. +Qed. +Global Opaque exp_hterm. + +Lemma exp_hterm_correct e hd hod: + WHEN exp_hterm e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. +Proof. + unfold wlp; intros; eapply exp_hterm_correct_x; eauto. +Qed. +Hint Resolve exp_hterm_correct: wlp. + +Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := + match i with + | nil => RET hd + | (x, e)::i' => + DO ht <~ exp_hterm e hd hod;; + DO nd <~ hsmem_set hd x ht;; + hinst_smem i' nd hod + end. + +Lemma hinst_smem_correct i: forall hd hod, + WHEN hinst_smem i hd hod ~> hd' THEN + forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. +Proof. + Local Hint Resolve smem_valid_set_proof: core. + induction i; simpl; wlp_simplify; eauto 15 with wlp. +Qed. +Global Opaque hinst_smem. +Local Hint Resolve hinst_smem_correct: wlp. + +(* logging info: we log the number of inst-instructions passed ! *) +Variable log_new_inst: unit -> ?? unit. + +Fixpoint bblock_hsmem_rec (p: bblock) (d: hsmem): ?? hsmem := + match p with + | nil => RET d + | i::p' => + log_new_inst tt;; + DO d' <~ hinst_smem i d d;; + bblock_hsmem_rec p' d' + end. + +Lemma bblock_hsmem_rec_correct p: forall hd, + WHEN bblock_hsmem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. +Proof. + induction p; simpl; wlp_simplify. +Qed. +Global Opaque bblock_hsmem_rec. +Local Hint Resolve bblock_hsmem_rec_correct: wlp. + +Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}. + +Lemma hsmem_empty_correct ge: smem_model ge smem_empty hsmem_empty. +Proof. + unfold smem_model, smem_valid, hsmem_post_eval; simpl; intuition try congruence. + rewrite !Dict.empty_spec; simpl; auto. +Qed. + +Definition bblock_hsmem: bblock -> ?? hsmem + := fun p => bblock_hsmem_rec p hsmem_empty. + +Lemma bblock_hsmem_correct p: + WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. +Proof. + Local Hint Resolve hsmem_empty_correct: core. + wlp_simplify. +Qed. +Global Opaque bblock_hsmem. + +End CanonBuilding. + +(* Now, we build the hash-Cons value from a "hash_eq". + +Informal specification: + [hash_eq] must be consistent with the "hashed" constructors defined above. + +We expect that hashinfo values in the code of these "hashed" constructors verify: + + (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) + +*) + +Definition term_hash_eq (ta tb: term): ?? bool := + match ta, tb with + | Input xa _, Input xb _ => + if R.eq_dec xa xb (* Inefficient in some cases ? *) + then RET true + else RET false + | App oa lta _, App ob ltb _ => + DO b <~ op_eq oa ob ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma term_hash_eq_correct: forall ta tb, WHEN term_hash_eq ta tb ~> b THEN b=true -> term_set_hid ta unknown_hid=term_set_hid tb unknown_hid. +Proof. + Local Hint Resolve op_eq_correct: wlp. + destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque term_hash_eq. +Hint Resolve term_hash_eq_correct: wlp. + +Definition list_term_hash_eq (lta ltb: list_term): ?? bool := + match lta, ltb with + | LTnil _, LTnil _ => RET true + | LTcons ta lta _, LTcons tb ltb _ => + DO b <~ phys_eq ta tb ;; + if b then phys_eq lta ltb + else RET false + | _,_ => RET false + end. + +Lemma list_term_hash_eq_correct: forall lta ltb, WHEN list_term_hash_eq lta ltb ~> b THEN b=true -> list_term_set_hid lta unknown_hid=list_term_set_hid ltb unknown_hid. +Proof. + destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). +Qed. +Global Opaque list_term_hash_eq. +Hint Resolve list_term_hash_eq_correct: wlp. + +Lemma hsmem_post_eval_intro (d1 d2: hsmem): + (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, hsmem_post_eval ge d1 x m = hsmem_post_eval ge d2 x m). +Proof. + unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. +Qed. + +Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp. + +Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := + {| + Dict.test_eq := phys_eq; + Dict.hashing := fun (ht: term) => RET (term_get_hid ht); + Dict.log := log |}. +Obligation 1. + eauto with wlp. +Qed. + +(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) +Definition no_log_assign (x:R.t) (t:term): ?? unit := RET tt. +Definition no_log_new_term (t:term): ?? unit := RET tt. + +Section Prog_Eq_Gen. + +Variable log_assign: R.t -> term -> ?? unit. +Variable log_new_term: hashConsing term -> hashConsing list_term -> ??(term -> ?? unit). +Variable log_inst1: unit -> ?? unit. (* log of p1 insts *) +Variable log_inst2: unit -> ?? unit. (* log of p2 insts *) + +Variable hco_term: hashConsing term. +Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. + +Variable hco_list: hashConsing list_term. +Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. + +Variable print_error_end: hsmem -> hsmem -> ?? unit. +Variable print_error: pstring -> ?? unit. + +Variable check_failpreserv: bool. +Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) + +Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := + DO failure_in_failpreserv <~ make_cref false;; + DO r <~ (TRY + DO d1 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; + DO log_new_term <~ log_new_term hco_term hco_list;; + DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; + DO b <~ Dict.eq_test d1 d2 ;; + if b then ( + if check_failpreserv then ( + let hp := mk_hash_params dbg_failpreserv in + failure_in_failpreserv.(set)(true);; + Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; + RET true + ) else RET false + ) else ( + print_error_end d1 d2 ;; + RET false + ) + CATCH_FAIL s, _ => + DO b <~ failure_in_failpreserv.(get)();; + if b then RET false + else print_error s;; RET false + ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; + RET (`r). +Obligation 1. + constructor 1; wlp_simplify; try congruence. + destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. + apply bblock_smem_simu; auto. split. + + intros m; rewrite <- EQPRE1, <- EQPRE2. + rewrite ! allvalid_extensionality. + unfold incl in * |- *; intuition eauto. + + intros m0 x VALID; rewrite <- EQPOST1, <- EQPOST2; auto. + erewrite hsmem_post_eval_intro; eauto. + erewrite <- EQPRE2; auto. + erewrite <- EQPRE1 in VALID. + rewrite ! allvalid_extensionality in * |- *. + unfold incl in * |- *; intuition eauto. +Qed. + +Theorem g_bblock_simu_test_correct p1 p2: + WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. + destruct exta0; simpl in * |- *; auto. +Qed. +Global Opaque g_bblock_simu_test. + +End Prog_Eq_Gen. + + + +Definition hpt: hashP term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. +Definition hplt: hashP list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. + +Definition recover_hcodes (t:term): ??(hashinfo term) := + match t with + | Input x _ => + DO hv <~ hInput_hcodes x ;; + RET {| hdata := t; hcodes := hv |} + | App o l _ => + DO hv <~ hApp_hcodes o l ;; + RET {| hdata := t; hcodes := hv |} + end. + + +Definition msg_end_of_bblock: pstring :="--- unknown subterms in the graph". + +Definition log_new_term + (unknownHash_msg: term -> ?? pstring) + (hct:hashConsing term) + (hcl:hashConsing list_term) + : ?? (term -> ?? unit) := + DO clock <~ hct.(next_hid)();; + hct.(next_log) msg_end_of_bblock;; + hcl.(next_log) msg_end_of_bblock;; + RET (fun t => + DO ok <~ hash_older (term_get_hid t) clock;; + if ok + then + RET tt + else + DO ht <~ recover_hcodes t;; + hct.(remove) ht;; + DO msg <~ unknownHash_msg t;; + FAILWITH msg). + +Definition skip (_:unit): ?? unit := RET tt. + +Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". +Definition msg_error_on_end: pstring := "mismatch in final assignments !". +Definition msg_unknow_term: pstring := "unknown term". +Definition msg_number: pstring := "on 2nd bblock -- on inst num ". +Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)". + +Definition print_error_end (_ _: hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end). + +Definition print_error (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + println (msg_prefix +; msg_number +; n +; " -- " +; s). + +Definition failpreserv_error (_: term): ?? unit + := println (msg_prefix +; msg_notfailpreserv). + +Lemma term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + term_set_hid t1 hid1 = term_set_hid t2 hid2 -> term_eval ge t1 m = term_eval ge t2 m. +Proof. + intro H; erewrite <- term_eval_set_hid; rewrite H. apply term_eval_set_hid. +Qed. + +Lemma list_term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: + list_term_set_hid t1 hid1 = list_term_set_hid t2 hid2 -> list_term_eval ge t1 m = list_term_eval ge t2 m. +Proof. + intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. +Qed. + +Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core. + +Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := + DO log <~ count_logger ();; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + g_bblock_simu_test + no_log_assign + (log_new_term (fun _ => RET msg_unknow_term)) + skip + (log_insert log) + hco_term _ + hco_list _ + print_error_end + (print_error log) + true (* check_failpreserv *) + failpreserv_error + p1 p2. +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Local Hint Resolve g_bblock_simu_test_correct: core. + +Theorem bblock_simu_test_correct p1 p2: + WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque bblock_simu_test. + +(** This is only to print info on each bblock_simu_test run **) +Section Verbose_version. + +Variable string_of_name: R.t -> ?? pstring. +Variable string_of_op: op -> ?? pstring. + + +Local Open Scope string_scope. + +Definition string_term_hid (t: term): ?? pstring := + DO id <~ string_of_hashcode (term_get_hid t);; + RET ("E" +; (CamlStr id)). + +Definition string_list_hid (lt: list_term): ?? pstring := + DO id <~ string_of_hashcode (list_term_get_hid lt);; + RET ("L" +; (CamlStr id)). + +Definition print_raw_term (t: term): ?? unit := + match t with + | Input x _ => + DO s <~ string_of_name x;; + println( "init_access " +; s) + | App o (LTnil _) _ => + DO so <~ string_of_op o;; + println so + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_list_hid l;; + println (so +; " " +; sl) + end. + +(* +Definition print_raw_list(lt: list_term): ?? unit := + match lt with + | LTnil _=> println "" + | LTcons t l _ => + DO st <~ string_term_hid t;; + DO sl <~ string_list_hid l;; + println(st +; " " +; sl) + end. +*) + +Section PrettryPrint. + +Variable get_debug_info: term -> ?? option pstring. + +Fixpoint string_of_term (t: term): ?? pstring := + match t with + | Input x _ => string_of_name x + | App o (LTnil _) _ => string_of_op o + | App o l _ => + DO so <~ string_of_op o;; + DO sl <~ string_of_list_term l;; + RET (so +; "[" +; sl +; "]") + end +with string_of_list_term (l: list_term): ?? pstring := + match l with + | LTnil _ => RET (Str "") + | LTcons t (LTnil _) _ => + DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end + | LTcons t l' _ => + DO st <~ (DO dbg <~ get_debug_info t;; + match dbg with + | Some x => RET x + | None => string_of_term t + end);; + DO sl <~ string_of_list_term l';; + RET (st +; ";" +; sl) + end. + + +End PrettryPrint. + + +Definition pretty_term gdi t := + DO r <~ string_of_term gdi t;; + println(r). + +Fixpoint print_head (head: list pstring): ?? unit := + match head with + | i::head' => println (i);; print_head head' + | _ => RET tt + end. + +Definition print_term gdi (head: list pstring) (t: term): ?? unit := + print_head head;; + DO s <~ string_term_hid t;; + print (s +; ": ");; + print_raw_term t;; + DO dbg <~ gdi t;; + match dbg with + | Some x => + print("// " +; x +; " <- ");; + pretty_term gdi t + | None => RET tt + end. + +Definition print_list gdi (head: list pstring) (lt: list_term): ?? unit := + print_head head;; + DO s <~ string_list_hid lt ;; + print (s +; ": ");; + (* print_raw_list lt;; *) + DO ps <~ string_of_list_term gdi lt;; + println("[" +; ps +; "]"). + + +Definition print_tables gdi ext exl: ?? unit := + println "-- term table --" ;; + iterall ext (fun head _ pt => print_term gdi head pt.(hdata));; + println "-- list table --" ;; + iterall exl (fun head _ pl => print_list gdi head pl.(hdata));; + println "----------------". + +Definition print_final_debug gdi (d1 d2: hsmem): ?? unit + := DO b <~ Dict.not_eq_witness d1 d2 ;; + match b with + | Some x => + DO s <~ string_of_name x;; + println("mismatch on: " +; s);; + match Dict.get d1 x with + | None => println("=> unassigned in 1st bblock") + | Some t1 => + print("=> node expected from 1st bblock: ");; + pretty_term gdi t1 + end;; + match Dict.get d2 x with + | None => println("=> unassigned in 2nd bblock") + | Some t2 => + print("=> node found from 2nd bblock: ");; + pretty_term gdi t2 + end + | None => FAILWITH "bug in Dict.not_eq_witness ?" + end. + +Definition witness:= option term. + +Definition msg_term (cr: cref witness) t := + set cr (Some t);; + RET msg_unknow_term. + +Definition print_witness gdi cr (*msg*) := + DO wit <~ get cr ();; + match wit with + | Some t => + println("=> unknown term node: ");; + pretty_term gdi t (*;; + println("=> encoded on " +; msg +; " graph as: ");; + print_raw_term t *) + | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" + end. + + +Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error_end d1 d2;; + print_final_debug gdi d1 d2. + +Definition print_error1 gdi hct hcl cr log s : ?? unit + := println "- GRAPH of 1st bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl;; + print_error log s;; + print_witness gdi cr (*"1st"*). + + +Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". + +Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit + := println (msg_prefix +; msg_error_on_end);; + println "- GRAPH of 2nd bblock";; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + print_tables gdi ext exl. + +Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit + := DO n <~ log_info log ();; + DO ext <~ export hct ();; + DO exl <~ export hcl ();; + println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; + print_witness gdi cr (*"2nd"*);; + println "- GRAPH of 2nd bblock";; + print_tables gdi ext exl. + +(* USELESS +Definition simple_log_assign (d: D.t term pstring) (x: R.t) (t: term): ?? unit := + DO s <~ string_of_name x;; + d.(D.set) (t,s). +*) + +Definition log_assign (d: D.t term pstring) (log: logger unit) (x: R.t) (t: term): ?? unit := + DO i <~ log_info log ();; + DO sx <~ string_of_name x;; + d.(D.set) (t,(sx +; "@" +; i)). + +Definition msg_new_inst : pstring := "--- inst ". + +Definition hlog (log: logger unit) (hct: hashConsing term) (hcl: hashConsing list_term): unit -> ?? unit := + (fun _ => + log_insert log tt ;; + DO s <~ log_info log tt;; + let s:= msg_new_inst +; s in + next_log hct s;; + next_log hcl s + ). + +Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + DO result1 <~ g_bblock_simu_test + (log_assign dict_info log1) + (log_new_term (msg_term cr)) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end1 dict_info.(D.get) hco_term hco_list) + (print_error1 dict_info.(D.get) hco_term hco_list cr log2) + true + failpreserv_error + p1 p2;; + if result1 + then RET true + else + DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; + DO log1 <~ count_logger ();; + DO log2 <~ count_logger ();; + DO cr <~ make_cref None;; + DO hco_term <~ mk_annot (hCons hpt);; + DO hco_list <~ mk_annot (hCons hplt);; + DO result2 <~ g_bblock_simu_test + (log_assign dict_info log1) + (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *) + (log_new_term (msg_term cr)) (* REM: too strong ?? *) + (hlog log1 hco_term hco_list) + (log_insert log2) + hco_term _ + hco_list _ + (print_error_end2 dict_info.(D.get) hco_term hco_list) + (print_error2 dict_info.(D.get) hco_term hco_list cr log2) + false + (fun _ => RET tt) + p2 p1;; + if result2 + then ( + println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; + RET false + ) else RET false + . +Obligation 1. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 2. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. +Obligation 3. + generalize (hCons_correct _ _ _ H0); clear H0. + wlp_simplify. +Qed. +Obligation 4. + generalize (hCons_correct _ _ _ H); clear H. + wlp_simplify. +Qed. + +Theorem verb_bblock_simu_test_correct p1 p2: + WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. +Proof. + wlp_simplify. +Qed. +Global Opaque verb_bblock_simu_test. + +End Verbose_version. + +End SimuWithReduce. + +(* TODO: why inlining fails here ? *) +Transparent hterm_lift. +Extraction Inline lift. + +End ImpSimu. + +Require Import FMapPositive. + + +Require Import PArith. +Require Import FMapPositive. + +Module ImpPosDict <: ImpDict with Module R:=Pos. + +Module R:=Pos. + +Definition t:=PositiveMap.t. + +Definition get {A} (d:t A) (x:R.t): option A + := PositiveMap.find x d. + +Definition set {A} (d:t A) (x:R.t) (v:A): t A + := PositiveMap.add x v d. + +Local Hint Unfold PositiveMap.E.eq: core. + +Lemma set_spec_eq A d x (v: A): + get (set d x v) x = Some v. +Proof. + unfold get, set; apply PositiveMap.add_1; auto. +Qed. + +Lemma set_spec_diff A d x y (v: A): + x <> y -> get (set d x v) y = get d y. +Proof. + unfold get, set; intros; apply PositiveMap.gso; auto. +Qed. + +Definition rem {A} (d:t A) (x:R.t): t A + := PositiveMap.remove x d. + +Lemma rem_spec_eq A (d: t A) x: + get (rem d x) x = None. +Proof. + unfold get, rem; apply PositiveMap.grs; auto. +Qed. + +Lemma rem_spec_diff A (d: t A) x y: + x <> y -> get (rem d x) y = get d y. +Proof. + unfold get, rem; intros; apply PositiveMap.gro; auto. +Qed. + + +Definition empty {A}: t A := PositiveMap.empty A. + +Lemma empty_spec A x: + get (empty (A:=A)) x = None. +Proof. + unfold get, empty; apply PositiveMap.gempty; auto. +Qed. + +Import PositiveMap. + +Fixpoint eq_test {A} (d1 d2: t A): ?? bool := + match d1, d2 with + | Leaf _, Leaf _ => RET true + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + else + RET false + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ eq_test l1 l2 ;; + if b1 then + eq_test r1 r2 + else + RET false + | _, _ => RET false + end. + +Lemma eq_test_correct A d1: forall (d2: t A), + WHEN eq_test d1 d2 ~> b THEN + b=true -> forall x, get d1 x = get d2 x. +Proof. + unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; + wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). +Qed. +Global Opaque eq_test. + +(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) +Fixpoint pick {A} (d: t A): ?? R.t := + match d with + | Leaf _ => FAILWITH "unexpected empty dictionary" + | Node _ (Some _) _ => RET xH + | Node (Leaf _) None r => + DO p <~ pick r;; + RET (xI p) + | Node l None _ => + DO p <~ pick l;; + RET (xO p) + end. + +(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) +Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := + match d1, d2 with + | Leaf _, Leaf _ => RET None + | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => + DO b0 <~ phys_eq x1 x2 ;; + if b0 then + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + else + RET (Some xH) + | Node l1 None r1, Node l2 None r2 => + DO b1 <~ not_eq_witness l1 l2;; + match b1 with + | None => + DO b2 <~ not_eq_witness r1 r2;; + match b2 with + | None => RET None + | Some p => RET (Some (xI p)) + end + | Some p => RET (Some (xO p)) + end + | l, Leaf _ => DO p <~ pick l;; RET (Some p) + | Leaf _, r => DO p <~ pick r;; RET (Some p) + | _, _ => RET (Some xH) + end. + +End ImpPosDict. + diff --git a/kvx/abstractbb/Impure/ImpConfig.v b/kvx/abstractbb/Impure/ImpConfig.v new file mode 100644 index 00000000..dd9785b5 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpConfig.v @@ -0,0 +1,85 @@ +(** Impure Config for UNTRUSTED backend !!! *) + +Require Import ImpMonads. +Require Extraction. +(** Pure computations (used for extraction !) + +We keep module [Impure] opaque in order to check that Coq proof do not depend on +the implementation of [Impure]. + +*) + +Module Type ImpureView. + + Include MayReturnMonad. + +(* WARNING: THIS IS REALLY UNSAFE TO DECOMMENT THE "UnsafeImpure" module ! + + unsafe_coerce coerces an impure computation into a pure one ! + +*) + +(* START COMMENT *) + Module UnsafeImpure. + + Parameter unsafe_coerce: forall {A}, t A -> option A. + + Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x. + + Extraction Inline unsafe_coerce. + + End UnsafeImpure. +(* END COMMENT *) + + +End ImpureView. + + +Module Impure: ImpureView. + + Include IdentityMonad. + + Module UnsafeImpure. + + Definition unsafe_coerce {A} (x:t A) := Some x. + + Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x. + Proof. + unfold unsafe_coerce, mayRet; congruence. + Qed. + + End UnsafeImpure. + +End Impure. + + +(** Comment the above code and decomment this to test that coq proofs still work with an impure monad ! + +- this should fail only on extraction or if unsafe_coerce is used ! + +*) +(* +Module Impure: MayReturnMonad := PowerSetMonad. +*) + +Export Impure. + +Extraction Inline ret mk_annot. + + +(* WARNING. The following directive is unsound. + + Extraction Inline bind + +For example, it may lead to extract the following code as "true" (instead of an error raising code) + failwith "foo";;true + +*) + +Extract Inlined Constant bind => "(|>)". + + +Extract Constant t "" => "". (* This weird directive extracts [t] as "'a" instead of "'a t" *) +Extraction Inline t. + +Global Opaque t. diff --git a/kvx/abstractbb/Impure/ImpCore.v b/kvx/abstractbb/Impure/ImpCore.v new file mode 100644 index 00000000..508b3f19 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpCore.v @@ -0,0 +1,196 @@ +(** Impure monad for interface with impure code + +*) + +Require Export Program. +Require Export ImpConfig. + +(* Theory: bind + embed => dbind + +Program Definition dbind {A B} (k1: t A) (k2: forall (a:A), (mayRet k1 a) -> t B) : t B + := bind (mk_annot k1) (fun a => k2 a _). + +Lemma mayRet_dbind: forall (A B:Type) k1 k2 (b:B), + mayRet (dbind k1 k2) b -> exists a:A, exists H: (mayRet k1 a), mayRet (k2 a H) b. +Proof. + intros A B k1 k2 b H; decompose [ex and] (mayRet_bind _ _ _ _ _ H). + eapply ex_intro. + eapply ex_intro. + eauto. +Qed. + +*) + +Definition wlp {A:Type} (k: t A) (P: A -> Prop): Prop + := forall a, mayRet k a -> P a. + +(* Notations *) + +(* Print Grammar constr. *) + +Module Notations. + + Bind Scope impure_scope with t. + Delimit Scope impure_scope with impure. + + Notation "?? A" := (t A) (at level 0, A at level 95): impure_scope. + + Notation "k '~~>' a" := (mayRet k a) (at level 75, no associativity): impure_scope. + + Notation "'RET' a" := (ret a) (at level 0): impure_scope. + + Notation "'DO' x '<~' k1 ';;' k2" := (bind k1 (fun x => k2)) + (at level 55, k1 at level 53, x at level 99, right associativity): impure_scope. + + Notation "k1 ';;' k2" := (bind k1 (fun _ => k2)) + (at level 55, right associativity): impure_scope. + + Notation "'WHEN' k '~>' a 'THEN' R" := (wlp k (fun a => R)) + (at level 73, R at level 100, right associativity): impure_scope. + + Notation "'ASSERT' P" := (ret (A:=P) _) (at level 0, only parsing): impure_scope. + +End Notations. + +Import Notations. +Local Open Scope impure. + +Goal ((?? list nat * ??nat -> nat) = ((?? ((list nat) * ?? nat) -> nat)))%type. +Proof. + apply refl_equal. +Qed. + + +(* wlp lemmas for tactics *) + +Lemma wlp_unfold A (k:??A)(P: A -> Prop): + (forall a, k ~~> a -> P a) + -> wlp k P. +Proof. + auto. +Qed. + +Lemma wlp_monotone A (k:?? A) (P1 P2: A -> Prop): + wlp k P1 + -> (forall a, k ~~> a -> P1 a -> P2 a) + -> wlp k P2. +Proof. + unfold wlp; eauto. +Qed. + +Lemma wlp_forall A B (k:?? A) (P: B -> A -> Prop): + (forall x, wlp k (P x)) + -> wlp k (fun a => forall x, P x a). +Proof. + unfold wlp; auto. +Qed. + +Lemma wlp_ret A (P: A -> Prop) a: + P a -> wlp (ret a) P. +Proof. + unfold wlp. + intros H b H0. + rewrite <- (mayRet_ret _ a b H0). + auto. +Qed. + +Lemma wlp_bind A B (k1:??A) (k2: A -> ??B) (P: B -> Prop): + wlp k1 (fun a => wlp (k2 a) P) -> wlp (bind k1 k2) P. +Proof. + unfold wlp. + intros H a H0. + case (mayRet_bind _ _ _ _ _ H0); clear H0. + intuition eauto. +Qed. + +Lemma wlp_ifbool A (cond: bool) (k1 k2: ?? A) (P: A -> Prop): + (cond=true -> wlp k1 P) -> (cond=false -> wlp k2 P) -> wlp (if cond then k1 else k2) P. +Proof. + destruct cond; auto. +Qed. + +Lemma wlp_letprod (A B C: Type) (p: A*B) (k: A -> B -> ??C) (P: C -> Prop): + (wlp (k (fst p) (snd p)) P) + -> (wlp (let (x,y):=p in (k x y)) P). +Proof. + destruct p; simpl; auto. +Qed. + +Lemma wlp_sum (A B C: Type) (x: A+B) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): + (forall a, x=inl a -> wlp (k1 a) P) -> + (forall b, x=inr b -> wlp (k2 b) P) -> + (wlp (match x with inl a => k1 a | inr b => k2 b end) P). +Proof. + destruct x; simpl; auto. +Qed. + +Lemma wlp_sumbool (A B:Prop) (C: Type) (x: {A}+{B}) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): + (forall a, x=left a -> wlp (k1 a) P) -> + (forall b, x=right b -> wlp (k2 b) P) -> + (wlp (match x with left a => k1 a | right b => k2 b end) P). +Proof. + destruct x; simpl; auto. +Qed. + +Lemma wlp_option (A B: Type) (x: option A) (k1: A -> ??B) (k2: ??B) (P: B -> Prop): + (forall a, x=Some a -> wlp (k1 a) P) -> + (x=None -> wlp k2 P) -> + (wlp (match x with Some a => k1 a | None => k2 end) P). +Proof. + destruct x; simpl; auto. +Qed. + +(* Tactics + +MAIN tactics: + - xtsimplify "base": simplification using from hints in "base" database (in particular "wlp" lemmas). + - xtstep "base": only one step of simplification. + +For good performance, it is recommanded to have several databases. + +*) + +Ltac introcomp := + let a:= fresh "exta" in + let H:= fresh "Hexta" in + intros a H. + +(* decompose the current wlp goal using "introduction" rules *) +Ltac wlp_decompose := + apply wlp_ret + || apply wlp_bind + || apply wlp_ifbool + || apply wlp_letprod + || apply wlp_sum + || apply wlp_sumbool + || apply wlp_option + . + +(* this tactic simplifies the current "wlp" goal using any hint found via tactic "hint". *) +Ltac apply_wlp_hint hint := + eapply wlp_monotone; + [ hint; fail | idtac ] ; + simpl; introcomp. + +(* one step of wlp_xsimplify +*) +Ltac wlp_step hint := + match goal with + | |- (wlp _ _) => + wlp_decompose + || apply_wlp_hint hint + || (apply wlp_unfold; introcomp) + end. + +(* main general tactic +WARNING: for the good behavior of "wlp_xsimplify", "hint" must at least perform a "eauto". + +Example of use: + wlp_xsimplify (intuition eauto with base). +*) +Ltac wlp_xsimplify hint := + repeat (intros; subst; wlp_step hint; simpl; (tauto || hint)). + +Create HintDb wlp discriminated. + +Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). diff --git a/kvx/abstractbb/Impure/ImpExtern.v b/kvx/abstractbb/Impure/ImpExtern.v new file mode 100644 index 00000000..8fb3cf3b --- /dev/null +++ b/kvx/abstractbb/Impure/ImpExtern.v @@ -0,0 +1,7 @@ +(** Exporting Extern functions +*) + +Require Export ImpPrelude. +Require Export ImpIO. +Require Export ImpLoops. +Require Export ImpHCons. diff --git a/kvx/abstractbb/Impure/ImpHCons.v b/kvx/abstractbb/Impure/ImpHCons.v new file mode 100644 index 00000000..637116cc --- /dev/null +++ b/kvx/abstractbb/Impure/ImpHCons.v @@ -0,0 +1,199 @@ +Require Export ImpIO. + +Import Notations. +Local Open Scope impure. + + +Axiom string_of_hashcode: hashcode -> ?? caml_string. +Extract Constant string_of_hashcode => "string_of_int". + +Axiom hash: forall {A}, A -> ?? hashcode. +Extract Constant hash => "Hashtbl.hash". + +(**************************) +(* (Weak) Sets *) + + +Import Dict. + +Axiom make_dict: forall {A B}, (hash_params A) -> ?? Dict.t A B. +Extract Constant make_dict => "ImpHConsOracles.make_dict". + + +Module Sets. + +Definition t {A} (mod: A -> Prop) := Dict.t A {x | mod x}. + +Definition empty {A} (hp: hash_params A) {mod:A -> Prop}: ?? t mod := + make_dict hp. + +Program Fixpoint add {A} (l: list A) {mod: A -> Prop} (d: t mod): forall {H:forall x, List.In x l -> mod x}, ?? unit := + match l with + | nil => fun H => RET () + | x::l' => fun H => + d.(set)(x,x);; + add l' d + end. + +Program Definition create {A} (hp: hash_params A) (l:list A): ?? t (fun x => List.In x l) := + DO d <~ empty hp (mod:=fun x => List.In x l);; + add l (mod:=fun x => List.In x l) d (H:=_);; + RET d. +Global Opaque create. + +Definition is_present {A} (hp: hash_params A) (x:A) {mod} (d:t mod): ?? bool := + DO oy <~ (d.(get)) x;; + match oy with + | Some y => hp.(test_eq) x (`y) + | None => RET false + end. + +Local Hint Resolve test_eq_correct: wlp. + +Lemma is_present_correct A (hp: hash_params A) x mod (d:t mod): + WHEN is_present hp x d ~> b THEN b=true -> mod x. +Proof. + wlp_simplify; subst; eauto. + - apply proj2_sig. + - discriminate. +Qed. +Hint Resolve is_present_correct: wlp. +Global Opaque is_present. + +Definition msg_assert_incl: pstring := "Sets.assert_incl". + +Fixpoint assert_incl {A} (hp: hash_params A) (l: list A) {mod} (d:t mod): ?? unit := + match l with + | nil => RET () + | x::l' => + DO b <~ is_present hp x d;; + if b then + assert_incl hp l' d + else ( + hp.(log) x;; + FAILWITH msg_assert_incl + ) + end. + +Lemma assert_incl_correct A (hp: hash_params A) l mod (d:t mod): + WHEN assert_incl hp l d ~> _ THEN forall x, List.In x l -> mod x. +Proof. + induction l; wlp_simplify; subst; eauto. +Qed. +Hint Resolve assert_incl_correct: wlp. +Global Opaque assert_incl. + +Definition assert_list_incl {A} (hp: hash_params A) (l1 l2: list A): ?? unit := + (* println "";;print("dict_create ");;*) + DO d <~ create hp l2;; + (*print("assert_incl ");;*) + assert_incl hp l1 d. + +Lemma assert_list_incl_correct A (hp: hash_params A) l1 l2: + WHEN assert_list_incl hp l1 l2 ~> _ THEN List.incl l1 l2. +Proof. + wlp_simplify. +Qed. +Global Opaque assert_list_incl. +Hint Resolve assert_list_incl_correct: wlp. + +End Sets. + + + + +(********************************) +(* (Weak) HConsing *) + +Module HConsing. + +Export HConsingDefs. + +(* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) +Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A. +Extract Constant xhCons => "ImpHConsOracles.xhCons". + +Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". + +Definition hCons {A} (hp: hashP A): ?? (hashConsing A) := + DO hco <~ xhCons hp ;; + RET {| + hC := (fun x => + DO x' <~ hC hco x ;; + DO b0 <~ hash_eq hp x.(hdata) x' ;; + assert_b b0 hCons_eq_msg;; + RET x'); + next_hid := hco.(next_hid); + next_log := hco.(next_log); + export := hco.(export); + remove := hco.(remove) + |}. + + +Lemma hCons_correct A (hp: hashP A): + WHEN hCons hp ~> hco THEN + (forall x y, WHEN hp.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hp x)=(ignore_hid hp y)) -> + forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hp x.(hdata)=ignore_hid hp x'. +Proof. + wlp_simplify. +Qed. +Global Opaque hCons. +Hint Resolve hCons_correct: wlp. + + + +(* hashV: extending a given type with hash-consing *) +Record hashV {A:Type}:= { + data: A; + hid: hashcode +}. +Arguments hashV: clear implicits. + +Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashP (hashV A) := {| + hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data); + get_hid := hid; + set_hid := fun v id => {| data := v.(data); hid := id |} +|}. + +Definition liftHV (x:nat) := {| data := x; hid := unknown_hid |}. + +Definition hConsV {A} (hasheq: A -> A -> ?? bool): ?? (hashConsing (hashV A)) := + hCons (hashV_C hasheq). + +Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): + WHEN hConsV hasheq ~> hco THEN + (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> + forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). +Proof. + Local Hint Resolve f_equal2: core. + wlp_simplify. + exploit H; eauto. + + wlp_simplify. + + intros; congruence. +Qed. +Global Opaque hConsV. +Hint Resolve hConsV_correct: wlp. + +Definition hC_known {A} (hco:hashConsing (hashV A)) (unknownHash_msg: hashinfo (hashV A) -> ?? pstring) (x:hashinfo (hashV A)): ?? hashV A := + DO clock <~ hco.(next_hid)();; + DO x' <~ hco.(hC) x;; + DO ok <~ hash_older x'.(hid) clock;; + if ok + then RET x' + else + hco.(remove) x;; + DO msg <~ unknownHash_msg x;; + FAILWITH msg. + +Lemma hC_known_correct A (hco:hashConsing (hashV A)) msg x: + WHEN hC_known hco msg x ~> x' THEN + (forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data)) -> + x.(hdata).(data)=x'.(data). +Proof. + wlp_simplify. + unfold wlp in * |- ; eauto. +Qed. +Global Opaque hC_known. +Hint Resolve hC_known_correct: wlp. + +End HConsing. diff --git a/kvx/abstractbb/Impure/ImpIO.v b/kvx/abstractbb/Impure/ImpIO.v new file mode 100644 index 00000000..6c02c395 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpIO.v @@ -0,0 +1,159 @@ +(** Extension of Coq language with some IO and exception-handling operators. + +TODO: integration with http://coq.io/ ? + +*) + +Require Export ImpPrelude. + +Import Notations. +Local Open Scope impure. + +(** Printing functions *) + +Axiom print: pstring -> ?? unit. +Extract Constant print => "ImpIOOracles.print". + +Axiom println: pstring -> ?? unit. +Extract Constant println => "ImpIOOracles.println". + +Axiom read_line: unit -> ?? pstring. +Extract Constant read_line => "ImpIOOracles.read_line". + +Require Import ZArith. +Axiom string_of_Z: Z -> ?? pstring. +Extract Constant string_of_Z => "ImpIOOracles.string_of_Z". + +(** timer *) + +Axiom timer: forall {A B}, (A -> ?? B)*A -> ?? B. +Extract Constant timer => "ImpIOOracles.timer". + +(** Exception Handling *) + +Axiom exit_observer: Type. +Extract Constant exit_observer => "((unit -> unit) ref)". + +Axiom new_exit_observer: (unit -> ??unit) -> ??exit_observer. +Extract Constant new_exit_observer => "ImpIOOracles.new_exit_observer". + +Axiom set_exit_observer: exit_observer * (unit -> ??unit) -> ??unit. +Extract Constant set_exit_observer => "ImpIOOracles.set_exit_observer". + +Axiom exn: Type. +Extract Inlined Constant exn => "exn". + +Axiom raise: forall {A}, exn -> ?? A. +Extract Constant raise => "raise". + +Axiom exn2string: exn -> ?? pstring. +Extract Constant exn2string => "ImpIOOracles.exn2string". + +Axiom fail: forall {A}, pstring -> ?? A. +Extract Constant fail => "ImpIOOracles.fail". + +Axiom try_with_fail: forall {A}, (unit -> ?? A) * (pstring -> exn -> ??A) -> ??A. +Extract Constant try_with_fail => "ImpIOOracles.try_with_fail". + +Axiom try_with_any: forall {A}, (unit -> ?? A) * (exn -> ??A) -> ??A. +Extract Constant try_with_any => "ImpIOOracles.try_with_any". + +Notation "'RAISE' e" := (DO r <~ raise (A:=False) e ;; RET (match r with end)) (at level 0): impure_scope. +Notation "'FAILWITH' msg" := (DO r <~ fail (A:=False) msg ;; RET (match r with end)) (at level 0): impure_scope. + +Definition _FAILWITH {A:Type} msg: ?? A := FAILWITH msg. + +Example _FAILWITH_correct A msg (P: A -> Prop): + WHEN _FAILWITH msg ~> r THEN P r. +Proof. + wlp_simplify. +Qed. + +Notation "'TRY' k1 'WITH_FAIL' s ',' e '=>' k2" := (try_with_fail (fun _ => k1, fun s e => k2)) + (at level 55, k1 at level 53, right associativity): impure_scope. + +Notation "'TRY' k1 'WITH_ANY' e '=>' k2" := (try_with_any (fun _ => k1, fun e => k2)) + (at level 55, k1 at level 53, right associativity): impure_scope. + + +Program Definition assert_b (b: bool) (msg: pstring): ?? b=true := + match b with + | true => RET _ + | false => FAILWITH msg + end. + +Lemma assert_wlp_true msg b: WHEN assert_b b msg ~> _ THEN b=true. +Proof. + wlp_simplify. +Qed. + +Lemma assert_false_wlp msg (P: Prop): WHEN assert_b false msg ~> _ THEN P. +Proof. + simpl; wlp_simplify. +Qed. + +Program Definition try_catch_fail_ensure {A} (k1: unit -> ?? A) (k2: pstring -> exn -> ??A) (P: A -> Prop | wlp (k1 tt) P /\ (forall s e, wlp (k2 s e) P)): ?? { r | P r } + := TRY + DO r <~ mk_annot (k1 tt);; + RET (exist P r _) + WITH_FAIL s, e => + DO r <~ mk_annot (k2 s e);; + RET (exist P r _). +Obligation 2. + unfold wlp in * |- *; eauto. +Qed. + +Notation "'TRY' k1 'CATCH_FAIL' s ',' e '=>' k2 'ENSURE' P" := (try_catch_fail_ensure (fun _ => k1) (fun s e => k2) (exist _ P _)) + (at level 55, k1 at level 53, right associativity): impure_scope. + +Definition is_try_post {A} (P: A -> Prop) k1 k2 : Prop := + wlp (k1 ()) P /\ forall (e:exn), wlp (k2 e) P. + +Program Definition try_catch_ensure {A} k1 k2 (P:A->Prop|is_try_post P k1 k2): ?? { r | P r } + := TRY + DO r <~ mk_annot (k1 ());; + RET (exist P r _) + WITH_ANY e => + DO r <~ mk_annot (k2 e);; + RET (exist P r _). +Obligation 1. + unfold is_try_post, wlp in * |- *; intuition eauto. +Qed. +Obligation 2. + unfold is_try_post, wlp in * |- *; intuition eauto. +Qed. + +Notation "'TRY' k1 'CATCH' e '=>' k2 'ENSURE' P" := (try_catch_ensure (fun _ => k1) (fun e => k2) (exist _ P _)) + (at level 55, k1 at level 53, right associativity): impure_scope. + + +Program Example tryex {A} (x y:A) := + TRY (RET x) + CATCH _ => (RET y) + ENSURE (fun r => r = x \/ r = y). +Obligation 1. + split; wlp_simplify. +Qed. + +Program Example tryex_test {A} (x y:A): + WHEN tryex x y ~> r THEN `r <> x -> `r = y. +Proof. + wlp_simplify. destruct exta as [r [X|X]]; intuition. +Qed. + + +Program Example try_branch1 {A} (x:A): ?? { r | r = x} := + TRY (RET x) + CATCH e => (FAILWITH "!") + ENSURE _. +Obligation 1. + split; wlp_simplify. +Qed. + +Program Example try_branch2 {A} (x:A): ?? { r | r = x} := + TRY (FAILWITH "!") + CATCH e => (RET x) + ENSURE _. +Obligation 1. + split; wlp_simplify. +Qed. diff --git a/kvx/abstractbb/Impure/ImpLoops.v b/kvx/abstractbb/Impure/ImpLoops.v new file mode 100644 index 00000000..33376c19 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpLoops.v @@ -0,0 +1,123 @@ +(** Extension of Coq language with generic loops. *) + +Require Export ImpIO. + +Import Notations. +Local Open Scope impure. + + +(** While-loop iterations *) + +Axiom loop: forall {A B}, A * (A -> ?? (A+B)) -> ?? B. +Extract Constant loop => "ImpLoopOracles.loop". + + +Section While_Loop. + +(** Local Definition of "while-loop-invariant" *) +Let wli {S} cond body (I: S -> Prop) := forall s, I s -> cond s = true -> WHEN (body s) ~> s' THEN I s'. + +Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | (I s0 -> I s) /\ cond s = false} + := loop (A:={s | I s0 -> I s}) + (s0, + fun s => + match (cond s) with + | true => + DO s' <~ mk_annot (body s) ;; + RET (inl (A:={s | I s0 -> I s }) s') + | false => + RET (inr (B:={s | (I s0 -> I s) /\ cond s = false}) s) + end). +Obligation 2. + unfold wli, wlp in * |-; eauto. +Qed. +Extraction Inline while. + +End While_Loop. + + +Section Loop_Until_None. +(** useful to demonstrate a UNSAT property *) + +(** Local Definition of "loop-until-None-invariant" *) +Let luni {S} (body: S -> ?? (option S)) (I: S -> Prop) := forall s, I s -> WHEN (body s) ~> s' THEN match s' with Some s1 => I s1 | None => False end. + +Program Definition loop_until_None {S} body (I: S -> Prop | luni body I) s0: ?? ~(I s0) + := loop (A:={s | I s0 -> I s}) + (s0, + fun s => + DO s' <~ mk_annot (body s) ;; + match s' with + | Some s1 => RET (inl (A:={s | I s0 -> I s }) s1) + | None => RET (inr (B:=~(I s0)) _) + end). +Obligation 2. + refine (H2 s _ _ H0). auto. +Qed. +Obligation 3. + intros X; refine (H1 s _ _ H). auto. +Qed. +Extraction Inline loop_until_None. + +End Loop_Until_None. + + +(*********************************************) +(* A generic fixpoint from an equality test *) + +Record answ {A B: Type} {R: A -> B -> Prop} := { + input: A ; + output: B ; + correct: R input output +}. +Arguments answ {A B}. + +Definition msg: pstring := "wapply fails". + +Definition beq_correct {A} (beq: A -> A -> ?? bool) := + forall x y, WHEN beq x y ~> b THEN b=true -> x=y. + +Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ?? answ R) (x:A): ?? B := + DO a <~ k x;; + DO b <~ beq x (input a) ;; + assert_b b msg;; + RET (output a). + +Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool) (k: A -> ?? answ R) x: + beq_correct beq + -> WHEN wapply beq k x ~> y THEN R x y. +Proof. + unfold beq_correct; wlp_simplify. + destruct exta; simpl; auto. +Qed. +Local Hint Resolve wapply_correct: wlp. +Global Opaque wapply. + +Axiom xrec_set_option: recMode -> ?? unit. +Extract Constant xrec_set_option => "ImpLoopOracles.xrec_set_option". + +(* TODO: generalizaton to get beq (and a Hash function ?) in parameters ? *) +Axiom xrec: forall {A B}, ((A -> ?? B) -> A -> ?? B) -> ?? (A -> ?? B). +Extract Constant xrec => "ImpLoopOracles.xrec". + +Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop) := + forall f x, WHEN recF f x ~> z THEN (forall x', WHEN f x' ~> y THEN R x' y) -> R x z. + + +Program Definition rec {A B} beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): ?? (A -> ?? B) := + DO f <~ xrec (B:=answ R) (fun f x => + DO y <~ mk_annot (recF (wapply beq f) x) ;; + RET {| input := x; output := `y |});; + RET (wapply beq f). +Obligation 1. + eapply H1; eauto. clear H H1. + wlp_simplify. +Qed. + +Lemma rec_correct A B beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): + WHEN rec beq recF R H1 H2 ~> f THEN forall x, WHEN f x ~> y THEN R x y. +Proof. + wlp_simplify. +Qed. +Hint Resolve rec_correct: wlp. +Global Opaque rec. diff --git a/kvx/abstractbb/Impure/ImpMonads.v b/kvx/abstractbb/Impure/ImpMonads.v new file mode 100644 index 00000000..f01a2755 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpMonads.v @@ -0,0 +1,148 @@ +(** Impure monad for interface with impure code +*) + + +Require Import Program. + + +Module Type MayReturnMonad. + + Axiom t: Type -> Type. + + Axiom mayRet: forall {A:Type}, t A -> A -> Prop. + + Axiom ret: forall {A}, A -> t A. + + Axiom bind: forall {A B}, (t A) -> (A -> t B) -> t B. + + Axiom mk_annot: forall {A} (k: t A), t { a: A | mayRet k a }. + + Axiom mayRet_ret: forall A (a b:A), + mayRet (ret a) b -> a=b. + + Axiom mayRet_bind: forall A B k1 k2 (b:B), + mayRet (bind k1 k2) b -> exists a:A, mayRet k1 a /\ mayRet (k2 a) b. + +End MayReturnMonad. + + + +(** Model of impure computation as predicate *) +Module PowerSetMonad<: MayReturnMonad. + + Definition t (A:Type) := A -> Prop. + + Definition mayRet {A:Type} (k: t A) a: Prop := k a. + + Definition ret {A:Type} (a:A) := eq a. + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := + fun b => exists a, k1 a /\ k2 a b. + + Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := fun _ => True. + + Lemma mayRet_ret A (a b:A): mayRet (ret a) b -> a=b. + Proof. + unfold mayRet, ret. firstorder. + Qed. + + Lemma mayRet_bind A B k1 k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + unfold mayRet, bind. + firstorder. + Qed. + +End PowerSetMonad. + + +(** The identity interpretation *) +Module IdentityMonad<: MayReturnMonad. + + Definition t (A:Type) := A. + + (* may-return semantics of computations *) + Definition mayRet {A:Type} (a b:A): Prop := a=b. + + Definition ret {A:Type} (a:A) := a. + + Definition bind {A B:Type} (k1: A) (k2: A -> B) := k2 k1. + + Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } + := exist _ k (eq_refl k) . + + Lemma mayRet_ret (A:Type) (a b:A): mayRet (ret a) b -> a=b. + Proof. + intuition. + Qed. + + Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + firstorder. + Qed. + +End IdentityMonad. + + +(** Model of impure computation as state-transformers *) +Module StateMonad<: MayReturnMonad. + + Parameter St: Type. (* A global state *) + + Definition t (A:Type) := St -> A * St. + + Definition mayRet {A:Type} (k: t A) a: Prop := + exists s, fst (k s)=a. + + Definition ret {A:Type} (a:A) := fun (s:St) => (a,s). + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := + fun s0 => let r := k1 s0 in k2 (fst r) (snd r). + + Program Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := + fun s0 => let r := k s0 in (exist _ (fst r) _, snd r). + Obligation 1. + unfold mayRet; eauto. + Qed. + + Lemma mayRet_ret {A:Type} (a b:A): mayRet (ret a) b -> a=b. + Proof. + unfold mayRet, ret. firstorder. + Qed. + + Lemma mayRet_bind {A B:Type} k1 k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + unfold mayRet, bind. firstorder eauto. + Qed. + +End StateMonad. + +(** The deferred interpretation *) +Module DeferredMonad<: MayReturnMonad. + + Definition t (A:Type) := unit -> A. + + (* may-return semantics of computations *) + Definition mayRet {A:Type} (a: t A) (b:A): Prop := a tt=b. + + Definition ret {A:Type} (a:A) : t A := fun _ => a. + + Definition bind {A B:Type} (k1: t A) (k2: A -> t B) : t B := fun _ => k2 (k1 tt) tt. + + Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } + := fun _ => exist _ (k tt) (eq_refl (k tt)). + + Lemma mayRet_ret (A:Type) (a b: A): mayRet (ret a) b -> a=b. + Proof. + intuition. + Qed. + + Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): + mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. + Proof. + firstorder. + Qed. + +End DeferredMonad. diff --git a/kvx/abstractbb/Impure/ImpPrelude.v b/kvx/abstractbb/Impure/ImpPrelude.v new file mode 100644 index 00000000..de4c7973 --- /dev/null +++ b/kvx/abstractbb/Impure/ImpPrelude.v @@ -0,0 +1,206 @@ +Require Export String. +Require Export List. +Require Extraction. +Require Import Ascii. +Require Import BinNums. +Require Export ImpCore. +Require Export PArith. + + +Import Notations. +Local Open Scope impure. + +(** Impure lazy andb of booleans *) +Definition iandb (k1 k2: ??bool): ?? bool := + DO r1 <~ k1 ;; + if r1 then k2 else RET false. + +Extraction Inline iandb. (* Juste pour l'efficacité à l'extraction ! *) + +(** Strings for pretty-printing *) + +Axiom caml_string: Type. +Extract Constant caml_string => "string". + +(* New line *) +Definition nl: string := String (ascii_of_pos 10%positive) EmptyString. + +Inductive pstring: Type := + | Str: string -> pstring + | CamlStr: caml_string -> pstring + | Concat: pstring -> pstring -> pstring. + +Coercion Str: string >-> pstring. +Bind Scope string_scope with pstring. + +Notation "x +; y" := (Concat x y) + (at level 65, left associativity): string_scope. + +(** Coq references *) + +Record cref {A} := { + set: A -> ?? unit; + get: unit -> ?? A +}. +Arguments cref: clear implicits. + +Axiom make_cref: forall {A}, A -> ?? cref A. +Extract Constant make_cref => "(fun x -> let r = ref x in { set = (fun y -> r:=y); get = (fun () -> !r) })". + + +(** Data-structure for a logger *) + +Record logger {A:Type} := { + log_insert: A -> ?? unit; + log_info: unit -> ?? pstring; +}. +Arguments logger: clear implicits. + +Axiom count_logger: unit -> ?? logger unit. +Extract Constant count_logger => "(fun () -> let count = ref 0 in { log_insert = (fun () -> count := !count + 1); log_info = (fun () -> (CamlStr (string_of_int !count))) })". + + +(** Axioms of Physical equality *) + +Axiom phys_eq: forall {A}, A -> A -> ?? bool. + +Axiom phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. + + +(* We only check here that above axioms are not trivially inconsistent... + (but this does not prove the correctness of the extraction directive below). + *) +Module PhysEqModel. + +Definition phys_eq {A} (x y: A) := ret false. + +Lemma phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. +Proof. + wlp_simplify. discriminate. +Qed. + +End PhysEqModel. + +Extract Inlined Constant phys_eq => "(==)". +Hint Resolve phys_eq_correct: wlp. + + +Axiom struct_eq: forall {A}, A -> A -> ?? bool. +Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN if b then x=y else x<>y. +Extract Inlined Constant struct_eq => "(=)". +Hint Resolve struct_eq_correct: wlp. + + +(** Data-structure for generic hash-consing *) + +Axiom hashcode: Type. +Extract Constant hashcode => "int". + +(* NB: hashConsing is assumed to generate hash-code in ascending order. + This gives a way to check that a hash-consed value is older than an other one. +*) +Axiom hash_older: hashcode -> hashcode -> ?? bool. +Extract Inlined Constant hash_older => "(<)". + +Module Dict. + +Record hash_params {A:Type} := { + test_eq: A -> A -> ??bool; + test_eq_correct: forall x y, WHEN test_eq x y ~> r THEN r=true -> x=y; + hashing: A -> ??hashcode; + log: A -> ??unit (* for debugging only *) +}. +Arguments hash_params: clear implicits. + + +Record t {A B:Type} := { + set: A * B -> ?? unit; + get: A -> ?? option B +}. +Arguments t: clear implicits. + +End Dict. + +Module HConsingDefs. + +Record hashinfo {A: Type} := { + hdata: A; + hcodes: list hashcode; +}. +Arguments hashinfo: clear implicits. + +(* for inductive types with intrinsic hash-consing *) +Record hashP {A:Type}:= { + hash_eq: A -> A -> ?? bool; + get_hid: A -> hashcode; + set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *) +}. +Arguments hashP: clear implicits. + +Axiom unknown_hid: hashcode. +Extract Constant unknown_hid => "-1". + +Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid. + +Record hashExport {A:Type}:= { + get_info: hashcode -> ?? hashinfo A; + iterall: ((list pstring) -> hashcode -> hashinfo A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) +}. +Arguments hashExport: clear implicits. + +Record hashConsing {A:Type}:= { + hC: hashinfo A -> ?? A; + (**** below: debugging or internal functions ****) + next_hid: unit -> ?? hashcode; (* should be strictly less old than ignore_hid *) + remove: hashinfo A -> ??unit; (* SHOULD NOT BE USED ! *) + next_log: pstring -> ?? unit; (* insert a log info (for the next introduced element) -- regiven by [iterall export] below *) + export: unit -> ?? hashExport A ; +}. +Arguments hashConsing: clear implicits. + +End HConsingDefs. + +(** recMode: this is mainly for Tests ! *) +Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec. + + +(* This a copy-paste from definitions in CompCert/Lib/CoqLib.v *) +Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q. +Proof. auto. Qed. + +Ltac exploit x := + refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _ _) _) + || refine (modusponens _ _ (x _ _ _) _) + || refine (modusponens _ _ (x _ _) _) + || refine (modusponens _ _ (x _) _). diff --git a/kvx/abstractbb/Impure/LICENSE b/kvx/abstractbb/Impure/LICENSE new file mode 100644 index 00000000..65c5ca88 --- /dev/null +++ b/kvx/abstractbb/Impure/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/kvx/abstractbb/Impure/README.md b/kvx/abstractbb/Impure/README.md new file mode 100644 index 00000000..2b19d14a --- /dev/null +++ b/kvx/abstractbb/Impure/README.md @@ -0,0 +1,31 @@ +# `Impure`: importing OCaml functions as non-deterministic ones. + +The principle of this library is to encode the type `A -> B` of an +OCaml function as a type `A -> ?? B` in Coq, where `?? B` is the type +of an axiomatized monad that can be interpreted as `B -> Prop`. In +other word, this encoding abstracts an OCaml function as a function +returning a postcondition on its possible results (ie a relation between its +parameter and its result). Side-effects are simply ignored. And +reasoning on such a function is only possible in partial correctness. + +See further explanations and examples on [ImpureDemo](https://github.com/boulme/ImpureDemo). + +## Credits + +[Sylvain Boulmé](mailto:Sylvain.Boulme@univ-grenoble-alpes.fr). + +## Code Overview + +- [ImpMonads](ImpMonads.v) axioms of "impure computations" and some Coq models of these axioms. + +- [ImpConfig](ImpConfig.v) declares the `Impure` monad and defines its extraction. + +- [ImpCore](ImpCore.v) defines notations for the `Impure` monad and a `wlp_simplify` tactic (to reason about `Impure` functions in a Hoare-logic style). + +- [ImpPrelude](ImpPrelude.v) declares the data types exchanged with `Impure` oracles. + +- [ImpIO](ImpIO.v), [ImpLoops](ImpLoops.v), [ImpHCons](ImpHCons.v) declare `Impure` oracles and define operators from these oracles. + [ImpExtern](ImpExtern.v) exports all these impure operators. + +- [ocaml/](ocaml/) subdirectory containing the OCaml implementations of `Impure` oracles. + diff --git a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml new file mode 100644 index 00000000..2b66899b --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.ml @@ -0,0 +1,66 @@ +open ImpPrelude +open HConsingDefs + +let make_dict (type key) (p: key Dict.hash_params) = + let module MyHashedType = struct + type t = key + let equal = p.Dict.test_eq + let hash = p.Dict.hashing + end in + let module MyHashtbl = Hashtbl.Make(MyHashedType) in + let dict = MyHashtbl.create 1000 in + { + Dict.set = (fun (k,d) -> MyHashtbl.replace dict k d); + Dict.get = (fun k -> MyHashtbl.find_opt dict k) + } + + +exception Stop;; + +let xhCons (type a) (hp:a hashP) = + (* We use a hash-table, but a hash-set would be sufficient ! *) + (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *) + (* Ideally, a parameter would allow to select between the weak or full version *) + let module MyHashedType = struct + type t = a hashinfo + let equal x y = hp.hash_eq x.hdata y.hdata + let hash x = Hashtbl.hash x.hcodes + end in + let module MyHashtbl = Hashtbl.Make(MyHashedType) in + let pick t = + let res = ref None in + try + MyHashtbl.iter (fun k d -> res:=Some (k,d); raise Stop) t; + None + with + | Stop -> !res + in + let t = MyHashtbl.create 1000 in + let logs = ref [] in + { + hC = (fun (k:a hashinfo) -> + match MyHashtbl.find_opt t k with + | Some d -> d + | None -> (*print_string "+";*) + let d = hp.set_hid k.hdata (MyHashtbl.length t) in + MyHashtbl.add t {k with hdata = d } d; d); + next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); + next_hid = (fun () -> MyHashtbl.length t); + remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x); + export = fun () -> + match pick t with + | None -> { get_info = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } + | Some (k,_) -> + (* the state is fully copied at export ! *) + let logs = ref (List.rev_append (!logs) []) in + let rec step_log i = + match !logs with + | (j, info)::l' when i>=j -> logs:=l'; info::(step_log i) + | _ -> [] + in let a = Array.make (MyHashtbl.length t) k in + MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t; + { + get_info = (fun i -> a.(i)); + iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a) + } + } diff --git a/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli new file mode 100644 index 00000000..5075d176 --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpHConsOracles.mli @@ -0,0 +1,5 @@ +open ImpPrelude +open HConsingDefs + +val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t +val xhCons: 'a hashP -> 'a hashConsing diff --git a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml b/kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml new file mode 100644 index 00000000..9e63c12d --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpIOOracles.ml @@ -0,0 +1,142 @@ +(* Warning + +These oracles assumes the following extraction directives: + "Require Import ExtrOcamlString." + +*) + +open ImpPrelude +(* +open BinNums +open Datatypes +*) + +(* two auxiliary functions, for efficient mapping of "int" to "BinNums.positive" *) +exception Overflow + +let aux_add: ('a, 'b) Hashtbl.t -> 'b Queue.t -> 'a -> 'b -> unit + = fun t q i p -> + if i < 1 then (* protection against wrap around *) + raise Overflow; + Queue.add p q; + Hashtbl.add t i p + +let memo_int2pos: int -> int -> BinNums.positive + = fun n -> + (* init of the Hashtbl *) + let n = max n 1 in + let t = Hashtbl.create n in + let q = Queue.create () in + aux_add t q 1 BinNums.Coq_xH ; + for i = 1 to (n-1)/2 do + let last = Queue.take q in + let ni = 2*i in + aux_add t q ni (BinNums.Coq_xO last); + aux_add t q (ni+1) (BinNums.Coq_xI last) + done; + if n mod 2 = 0 then ( + let last = Queue.take q in + Hashtbl.add t n (BinNums.Coq_xO last) + ); + (* memoized translation of i *) + let rec find i = + try + (* Printf.printf "-> %d\n" i; *) + Hashtbl.find t i + with Not_found -> + (* Printf.printf "<- %d\n" i; *) + if i <= 0 then + invalid_arg "non-positive integer" + else + let p = find (i/2) in + let pi = if i mod 2 = 0 then BinNums.Coq_xO p else BinNums.Coq_xI p in + Hashtbl.add t i pi; + pi + in find;; + +let new_exit_observer: (unit -> unit) -> (unit -> unit) ref + = fun f -> + let o = ref f in + at_exit (fun () -> !o()); + o;; + +let set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit + = fun (r, f) -> r := f + +let rec print: pstring -> unit + = fun ps -> + match ps with + | Str l -> List.iter print_char l + | CamlStr s -> print_string s + | Concat(ps1,ps2) -> (print ps1; print ps2);; + +let println: pstring -> unit + = fun l -> print l; print_newline() + +let read_line () = + CamlStr (Stdlib.read_line());; + +exception ImpureFail of pstring;; + +let exn2string: exn -> pstring + = fun e -> CamlStr (Printexc.to_string e) + +let fail: pstring -> 'a + = fun s -> raise (ImpureFail s);; + +let try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a + = fun (k1, k2) -> + try + k1() + with + | (ImpureFail s) as e -> k2 s e + +let try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a + = fun (k1, k2) -> + try + k1() + with + | e -> k2 e + +(** MISC **) + +let rec posTr: BinNums.positive -> int += function + | BinNums.Coq_xH -> 1 + | BinNums.Coq_xO p -> (posTr p)*2 + | BinNums.Coq_xI p -> (posTr p)*2+1;; + +let zTr: BinNums.coq_Z -> int += function + | BinNums.Z0 -> 0 + | BinNums.Zpos p -> posTr p + | BinNums.Zneg p -> - (posTr p) + +let ten = BinNums.Zpos (BinNums.Coq_xO (BinNums.Coq_xI (BinNums.Coq_xO BinNums.Coq_xH))) + +let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring += let (q,r) = BinInt.Z.pos_div_eucl p ten in + let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in + match q with + | BinNums.Z0 -> acc0 + | BinNums.Zpos p0 -> string_of_pos p0 acc0 + | _ -> assert false + +(* +let string_of_Z_debug: BinNums.coq_Z -> pstring += fun p -> CamlStr (string_of_int (zTr p)) +*) + +let string_of_Z: BinNums.coq_Z -> pstring += function + | BinNums.Z0 -> CamlStr "0" + | BinNums.Zpos p -> string_of_pos p (CamlStr "") + | BinNums.Zneg p -> Concat (CamlStr "-", string_of_pos p (CamlStr "")) + +let timer ((f:'a -> 'b), (x:'a)) : 'b = + Gc.compact(); + let itime = (Unix.times()).Unix.tms_utime in + let r = f x in + let rt = (Unix.times()).Unix.tms_utime -. itime in + Printf.printf "time = %f\n" rt; + r diff --git a/kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli b/kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli new file mode 100644 index 00000000..6064286a --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpIOOracles.mli @@ -0,0 +1,33 @@ +open ImpPrelude + + +(* +Memoized version of translation from int -> BinNums.positive. +The first arg is an indicative bound on the max int translated: +it pre-computes all positives lower or equal to this bound. +*) +val memo_int2pos: int -> int -> BinNums.positive + +val read_line: unit -> pstring + +val print: pstring -> unit + +val println: pstring -> unit + +val string_of_Z: BinNums.coq_Z -> pstring + +val timer : (('a -> 'b ) * 'a) -> 'b + +val new_exit_observer: (unit -> unit) -> (unit -> unit) ref + +val set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit + +val exn2string: exn -> pstring + +val fail: pstring -> 'a + +exception ImpureFail of pstring;; + +val try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a + +val try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a diff --git a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml b/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml new file mode 100644 index 00000000..cb7625e5 --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.ml @@ -0,0 +1,78 @@ +open ImpPrelude +open Datatypes + +(** GENERIC ITERATIVE LOOP **) + +(* a simple version of loop *) +let simple_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + = fun (a0, f) -> + let rec iter: 'a -> 'b + = fun a -> + match f a with + | Coq_inl a' -> iter a' + | Coq_inr b -> b + in + iter a0;; + +(* loop from while *) +let while_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + = fun (a0, f) -> + let s = ref (f a0) in + while (match !s with Coq_inl _ -> true | _ -> false) do + match !s with + | Coq_inl a -> s:=f a + | _ -> assert false + done; + match !s with + | Coq_inr b -> b + | _ -> assert false;; + +let loop = simple_loop + + +(** GENERIC FIXPOINTS **) + +let std_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let rec f x = recf f x in + f + +let memo_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let memo = Hashtbl.create 10 in + let rec f x = + try + Hashtbl.find memo x + with + Not_found -> + let r = recf f x in + Hashtbl.replace memo x r; + r + in f + +let bare_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let fix = ref (fun x -> failwith "init") in + fix := (fun x -> recf !fix x); + !fix;; + +let buggy_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = + let memo = ref None in + let rec f x = + match !memo with + | Some y -> y + | None -> + let r = recf f x in + memo := Some r; + r + in f + +let xrec_mode = ref MemoRec + +let xrec_set_option : recMode -> unit += fun m -> xrec_mode := m + +let xrec : (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) + = fun recf -> + match !xrec_mode with + | StdRec -> std_rec recf + | MemoRec -> memo_rec recf + | BareRec -> bare_rec recf + | BuggyRec -> buggy_rec recf diff --git a/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli b/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli new file mode 100644 index 00000000..194696a1 --- /dev/null +++ b/kvx/abstractbb/Impure/ocaml/ImpLoopOracles.mli @@ -0,0 +1,8 @@ +open ImpPrelude +open Datatypes + +val loop: ('a * ('a -> ('a, 'b) sum)) -> 'b + +val xrec_set_option: recMode -> unit + +val xrec: (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) diff --git a/kvx/abstractbb/Parallelizability.v b/kvx/abstractbb/Parallelizability.v new file mode 100644 index 00000000..feebeee5 --- /dev/null +++ b/kvx/abstractbb/Parallelizability.v @@ -0,0 +1,793 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** Parallel Semantics of Abstract Basic Blocks and parallelizability test. +*) + +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. + +Require Import List. +Import ListNotations. +Local Open Scope list_scope. + +Require Import Sorting.Permutation. +Require Import Bool. +Local Open Scope lazy_bool_scope. + + +Module ParallelSemantics (L: SeqLanguage). + +Export L. +Local Open Scope list. + +Section PARALLEL. +Variable ge: genv. + +(* parallel run of a inst *) +Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem := + match i with + | nil => Some m + | (x, e)::i' => + match exp_eval ge e tmp old with + | Some v' => inst_prun i' (assign m x v') (assign tmp x v') old + | None => None + end + end. + +(* [inst_prun] is generalization of [inst_run] *) +Lemma inst_run_prun i: forall m old, + inst_run ge i m old = inst_prun i m m old. +Proof. + induction i as [|[y e] i']; simpl; auto. + intros m old; destruct (exp_eval ge e m old); simpl; auto. +Qed. + + +(* parallel run of a bblock -- with in-order writes *) +Fixpoint prun_iw (p: bblock) m old: option mem := + match p with + | nil => Some m + | i::p' => + match inst_prun i m old old with + | Some m1 => prun_iw p' m1 old + | None => None + end + end. + +(* non-deterministic parallel run, due to arbitrary writes order *) +Definition prun (p: bblock) m (om: option mem) := exists p', res_eq om (prun_iw p' m m) /\ Permutation p p'. + + +(* a few lemma on equality *) + +Lemma inst_prun_equiv i old: forall m1 m2 tmp, + (forall x, m1 x = m2 x) -> + res_eq (inst_prun i m1 tmp old) (inst_prun i m2 tmp old). +Proof. + induction i as [|[x e] i']; simpl; eauto. + intros m1 m2 tmp H; destruct (exp_eval ge e tmp old); simpl; auto. + eapply IHi'; unfold assign. intros; destruct (R.eq_dec x x0); auto. +Qed. + +Lemma prun_iw_equiv p: forall m1 m2 old, + (forall x, m1 x = m2 x) -> + res_eq (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + induction p as [|i p']; simpl; eauto. + - intros m1 m2 old H. + generalize (inst_prun_equiv i old m1 m2 old H); + destruct (inst_prun i m1 old old); simpl. + + intros (m3 & H3 & H4); rewrite H3; simpl; eauto. + + intros H1; rewrite H1; simpl; auto. +Qed. + + +Lemma prun_iw_app p1: forall m1 old p2, + prun_iw (p1++p2) m1 old = + match prun_iw p1 m1 old with + | Some m2 => prun_iw p2 m2 old + | None => None + end. +Proof. + induction p1; simpl; try congruence. + intros; destruct (inst_prun _ _ _); simpl; auto. +Qed. + +Lemma prun_iw_app_None p1: forall m1 old p2, + prun_iw p1 m1 old = None -> + prun_iw (p1++p2) m1 old = None. +Proof. + intros m1 old p2 H; rewrite prun_iw_app. rewrite H; auto. +Qed. + +Lemma prun_iw_app_Some p1: forall m1 old m2 p2, + prun_iw p1 m1 old = Some m2 -> + prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. +Proof. + intros m1 old m2 p2 H; rewrite prun_iw_app. rewrite H; auto. +Qed. + +End PARALLEL. +End ParallelSemantics. + + + +Fixpoint notIn {A} (x: A) (l:list A): Prop := + match l with + | nil => True + | a::l' => x <> a /\ notIn x l' + end. + +Lemma notIn_iff A (x:A) l: (~List.In x l) <-> notIn x l. +Proof. + induction l; simpl; intuition. +Qed. + +Lemma notIn_app A (x:A) l1: forall l2, notIn x (l1++l2) <-> (notIn x l1 /\ notIn x l2). +Proof. + induction l1; simpl. + - intuition. + - intros; rewrite IHl1. intuition. +Qed. + + +Lemma In_Permutation A (l1 l2: list A): Permutation l1 l2 -> forall x, In x l1 -> In x l2. +Proof. + induction 1; simpl; intuition. +Qed. + +Lemma Permutation_incl A (l1 l2: list A): Permutation l1 l2 -> incl l1 l2. +Proof. + unfold incl; intros; eapply In_Permutation; eauto. +Qed. + +Lemma notIn_incl A (l1 l2: list A) x: incl l1 l2 -> notIn x l2 -> notIn x l1. +Proof. + unfold incl; rewrite <- ! notIn_iff; intuition. +Qed. + + +Definition disjoint {A: Type} (l l':list A) : Prop := forall x, In x l -> notIn x l'. + +Lemma disjoint_sym_imp A (l1 l2: list A): disjoint l1 l2 -> disjoint l2 l1. +Proof. + unfold disjoint. intros H x H1. generalize (H x). rewrite <- !notIn_iff. intuition. +Qed. + +Lemma disjoint_sym A (l1 l2: list A): disjoint l1 l2 <-> disjoint l2 l1. +Proof. + constructor 1; apply disjoint_sym_imp; auto. +Qed. + + +Lemma disjoint_cons_l A (x:A) (l1 l2: list A): disjoint (x::l1) l2 <-> (notIn x l2) /\ (disjoint l1 l2). +Proof. + unfold disjoint. simpl; intuition subst; auto. +Qed. + +Lemma disjoint_cons_r A (x:A) (l1 l2: list A): disjoint l1 (x::l2) <-> (notIn x l1) /\ (disjoint l1 l2). +Proof. + rewrite disjoint_sym, disjoint_cons_l, disjoint_sym; intuition. +Qed. + +Lemma disjoint_app_r A (l l1 l2: list A): disjoint l (l1++l2) <-> (disjoint l l1 /\ disjoint l l2). +Proof. + unfold disjoint. intuition. + - generalize (H x H0). rewrite notIn_app; intuition. + - generalize (H x H0). rewrite notIn_app; intuition. + - rewrite notIn_app; intuition. +Qed. + +Lemma disjoint_app_l A (l l1 l2: list A): disjoint (l1++l2) l <-> (disjoint l1 l /\ disjoint l2 l). +Proof. + rewrite disjoint_sym, disjoint_app_r; intuition; rewrite disjoint_sym; auto. +Qed. + +Lemma disjoint_incl_r A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l l2 -> disjoint l l1. +Proof. + unfold disjoint. intros; eapply notIn_incl; eauto. +Qed. + +Lemma disjoint_incl_l A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l2 l -> disjoint l1 l. +Proof. + intros; rewrite disjoint_sym. eapply disjoint_incl_r; eauto. rewrite disjoint_sym; auto. +Qed. + + +Module ParallelizablityChecking (L: SeqLanguage). + +Include ParallelSemantics L. + +Section PARALLELI. +Variable ge: genv. + +(** * Preliminary notions on frames *) + +Lemma notIn_dec (x: R.t) l : { notIn x l } + { In x l }. +Proof. + destruct (In_dec R.eq_dec x l). constructor 2; auto. + constructor 1; rewrite <- notIn_iff. auto. +Qed. + +Fixpoint frame_assign m1 (f: list R.t) m2 := + match f with + | nil => m1 + | x::f' => frame_assign (assign m1 x (m2 x)) f' m2 + end. + +Lemma frame_assign_def f: forall m1 m2 x, + frame_assign m1 f m2 x = if notIn_dec x f then m1 x else m2 x. +Proof. + induction f as [|y f] ; simpl; auto. + - intros; destruct (notIn_dec x []); simpl in *; tauto. + - intros; rewrite IHf; destruct (notIn_dec x (y::f)); simpl in *. + + destruct (notIn_dec x f); simpl in *; intuition. + rewrite assign_diff; auto. + rewrite <- notIn_iff in *; intuition. + + destruct (notIn_dec x f); simpl in *; intuition subst. + rewrite assign_eq; auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Lemma frame_assign_In m1 f m2 x: + In x f -> frame_assign m1 f m2 x = m2 x. +Proof. + intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Lemma frame_assign_notIn m1 f m2 x: + notIn x f -> frame_assign m1 f m2 x = m1 x. +Proof. + intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. + rewrite <- notIn_iff in *; intuition. +Qed. + +Definition frame_eq (frame: R.t -> Prop) (om1 om2: option mem): Prop := + match om1 with + | Some m1 => exists m2, om2 = Some m2 /\ forall x, (frame x) -> m1 x = m2 x + | None => om2 = None + end. + +Lemma frame_eq_list_split f1 (f2: R.t -> Prop) om1 om2: + frame_eq (fun x => In x f1) om1 om2 -> + (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> f2 x -> notIn x f1 -> m1 x = m2 x) -> + frame_eq f2 om1 om2. +Proof. + unfold frame_eq; destruct om1 as [ m1 | ]; simpl; auto. + intros (m2 & H0 & H1); subst. + intros H. + eexists; intuition eauto. + destruct (notIn_dec x f1); auto. +Qed. + +(* +Lemma frame_eq_res_eq f om1 om2: + frame_eq (fun x => In x f) om1 om2 -> + (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> notIn x f -> m1 x = m2 x) -> + res_eq om1 om2. +Proof. + intros H H0; lapply (frame_eq_list_split f (fun _ => True) om1 om2 H); eauto. + clear H H0; unfold frame_eq, res_eq. destruct om1; simpl; firstorder. +Qed. +*) + +(** * Writing frames *) + +Fixpoint inst_wframe(i:inst): list R.t := + match i with + | nil => nil + | a::i' => (fst a)::(inst_wframe i') + end. + +Lemma inst_wframe_correct i m' old: forall m tmp, + inst_prun ge i m tmp old = Some m' -> + forall x, notIn x (inst_wframe i) -> m' x = m x. +Proof. + induction i as [|[y e] i']; simpl. + - intros m tmp H x H0; inversion_clear H; auto. + - intros m tmp H x (H1 & H2); destruct (exp_eval ge e tmp old); simpl; try congruence. + cutrewrite (m x = assign m y v x); eauto. + rewrite assign_diff; auto. +Qed. + +Lemma inst_prun_fequiv i old: forall m1 m2 tmp, + frame_eq (fun x => In x (inst_wframe i)) (inst_prun ge i m1 tmp old) (inst_prun ge i m2 tmp old). +Proof. + induction i as [|[y e] i']; simpl. + - intros m1 m2 tmp; eexists; intuition eauto. + - intros m1 m2 tmp. destruct (exp_eval ge e tmp old); simpl; auto. + eapply frame_eq_list_split; eauto. clear IHi'. + intros m1' m2' x H1 H2. + lapply (inst_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. + lapply (inst_wframe_correct i' m2' old (assign m2 y v) (assign tmp y v)); eauto. + intros Xm2 Xm1 H H0. destruct H. + + subst. rewrite Xm1, Xm2; auto. rewrite !assign_eq. auto. + + rewrite <- notIn_iff in H0; tauto. +Qed. + +Lemma inst_prun_None i m1 m2 tmp old: + inst_prun ge i m1 tmp old = None -> + inst_prun ge i m2 tmp old = None. +Proof. + intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). + rewrite H; simpl; auto. +Qed. + +Lemma inst_prun_Some i m1 m2 tmp old m1': + inst_prun ge i m1 tmp old = Some m1' -> + res_eq (Some (frame_assign m2 (inst_wframe i) m1')) (inst_prun ge i m2 tmp old). +Proof. + intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). + rewrite H; simpl. + intros (m2' & H1 & H2). + eexists; intuition eauto. + rewrite frame_assign_def. + lapply (inst_wframe_correct i m2' old m2 tmp); eauto. + destruct (notIn_dec x (inst_wframe i)); auto. + intros X; rewrite X; auto. +Qed. + +Fixpoint bblock_wframe(p:bblock): list R.t := + match p with + | nil => nil + | i::p' => (inst_wframe i)++(bblock_wframe p') + end. + +Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core. + +Lemma bblock_wframe_Permutation p p': + Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). +Proof. + induction 1 as [|i p p'|i1 i2 p|p1 p2 p3]; simpl; auto. + - rewrite! app_assoc; auto. + - eapply Permutation_trans; eauto. +Qed. + +(* +Lemma bblock_wframe_correct p m' old: forall m, + prun_iw p m old = Some m' -> + forall x, notIn x (bblock_wframe p) -> m' x = m x. +Proof. + induction p as [|i p']; simpl. + - intros m H; inversion_clear H; auto. + - intros m H x; rewrite notIn_app; intros (H1 & H2). + remember (inst_prun i m old old) as om. + destruct om as [m1|]; simpl. + + eapply eq_trans. + eapply IHp'; eauto. + eapply inst_wframe_correct; eauto. + + inversion H. +Qed. + +Lemma prun_iw_fequiv p old: forall m1 m2, + frame_eq (fun x => In x (bblock_wframe p)) (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + induction p as [|i p']; simpl. + - intros m1 m2; eexists; intuition eauto. + - intros m1 m2; generalize (inst_prun_fequiv i old m1 m2 old). + remember (inst_prun i m1 old old) as om. + destruct om as [m1'|]; simpl. + + intros (m2' & H1 & H2). rewrite H1; simpl. + eapply frame_eq_list_split; eauto. clear IHp'. + intros m1'' m2'' x H3 H4. rewrite in_app_iff. + intros X X2. assert (X1: In x (inst_wframe i)). { destruct X; auto. rewrite <- notIn_iff in X2; tauto. } + clear X. + lapply (bblock_wframe_correct p' m1'' old m1'); eauto. + lapply (bblock_wframe_correct p' m2'' old m2'); eauto. + intros Xm2' Xm1'. + rewrite Xm1', Xm2'; auto. + + intro H; rewrite H; simpl; auto. +Qed. + +Lemma prun_iw_equiv p m1 m2 old: + (forall x, notIn x (bblock_wframe p) -> m1 x = m2 x) -> + res_eq (prun_iw p m1 old) (prun_iw p m2 old). +Proof. + intros; eapply frame_eq_res_eq. + eapply prun_iw_fequiv. + intros m1' m2' x H1 H2 H0.Require + lapply (bblock_wframe_correct p m1' old m1); eauto. + lapply (bblock_wframe_correct p m2' old m2); eauto. + intros X2 X1; rewrite X1, X2; auto. +Qed. +*) + +(** * Checking that parallel semantics is deterministic *) + +Fixpoint is_det (p: bblock): Prop := + match p with + | nil => True + | i::p' => + disjoint (inst_wframe i) (bblock_wframe p') (* no WRITE-AFTER-WRITE *) + /\ is_det p' + end. + +Lemma is_det_Permutation p p': + Permutation p p' -> is_det p -> is_det p'. +Proof. + induction 1; simpl; auto. + - intros; intuition. eapply disjoint_incl_r. 2: eauto. + eapply Permutation_incl. eapply Permutation_sym. + eapply bblock_wframe_Permutation; auto. + - rewrite! disjoint_app_r in * |- *. intuition. + rewrite disjoint_sym; auto. +Qed. + +Theorem is_det_correct p p': + Permutation p p' -> + is_det p -> + forall m old, res_eq (prun_iw ge p m old) (prun_iw ge p' m old). +Proof. + induction 1 as [ | i p p' | i1 i2 p | p1 p2 p3 ]; simpl; eauto. + - intros [H0 H1] m old. + remember (inst_prun ge i m old old) as om0. + destruct om0 as [ m0 | ]; simpl; auto. + - rewrite disjoint_app_r. + intros ([Z1 Z2] & Z3 & Z4) m old. + remember (inst_prun ge i2 m old old) as om2. + destruct om2 as [ m2 | ]; simpl; auto. + + remember (inst_prun ge i1 m old old) as om1. + destruct om1 as [ m1 | ]; simpl; auto. + * lapply (inst_prun_Some i2 m m1 old old m2); simpl; auto. + lapply (inst_prun_Some i1 m m2 old old m1); simpl; auto. + intros (m1' & Hm1' & Xm1') (m2' & Hm2' & Xm2'). + rewrite Hm1', Hm2'; simpl. + eapply prun_iw_equiv. + intros x; rewrite <- Xm1', <- Xm2'. clear Xm2' Xm1' Hm1' Hm2' m1' m2'. + rewrite frame_assign_def. + rewrite disjoint_sym in Z1; unfold disjoint in Z1. + destruct (notIn_dec x (inst_wframe i1)) as [ X1 | X1 ]. + { rewrite frame_assign_def; destruct (notIn_dec x (inst_wframe i2)) as [ X2 | X2 ]; auto. + erewrite (inst_wframe_correct i2 m2 old m old); eauto. + erewrite (inst_wframe_correct i1 m1 old m old); eauto. + } + rewrite frame_assign_notIn; auto. + * erewrite inst_prun_None; eauto. simpl; auto. + + remember (inst_prun ge i1 m old old) as om1. + destruct om1 as [ m1 | ]; simpl; auto. + erewrite inst_prun_None; eauto. + - intros; eapply res_eq_trans. + eapply IHPermutation1; eauto. + eapply IHPermutation2; eauto. + eapply is_det_Permutation; eauto. +Qed. + +(** * Standard Frames *) + +Fixpoint exp_frame (e: exp): list R.t := + match e with + | PReg x => x::nil + | Op o le => list_exp_frame le + | Old e => exp_frame e + end +with list_exp_frame (le: list_exp): list R.t := + match le with + | Enil => nil + | Econs e le' => exp_frame e ++ list_exp_frame le' + | LOld le => list_exp_frame le + end. + +Lemma exp_frame_correct e old1 old2: + (forall x, In x (exp_frame e) -> old1 x = old2 x) -> + forall m1 m2, (forall x, In x (exp_frame e) -> m1 x = m2 x) -> + (exp_eval ge e m1 old1)=(exp_eval ge e m2 old2). +Proof. + induction e using exp_mut with (P0:=fun l => (forall x, In x (list_exp_frame l) -> old1 x = old2 x) -> forall m1 m2, (forall x, In x (list_exp_frame l) -> m1 x = m2 x) -> + (list_exp_eval ge l m1 old1)=(list_exp_eval ge l m2 old2)); simpl; auto. + - intros H1 m1 m2 H2; rewrite H2; auto. + - intros H1 m1 m2 H2; erewrite IHe; eauto. + - intros H1 m1 m2 H2; erewrite IHe, IHe0; eauto; + intros; (eapply H1 || eapply H2); rewrite in_app_iff; auto. +Qed. + +Fixpoint inst_frame (i: inst): list R.t := + match i with + | nil => nil + | a::i' => (fst a)::(exp_frame (snd a) ++ inst_frame i') + end. + +Lemma inst_wframe_frame i x: In x (inst_wframe i) -> In x (inst_frame i). +Proof. + induction i as [ | [y e] i']; simpl; intuition. +Qed. + + +Lemma inst_frame_correct i wframe old1 old2: forall m tmp1 tmp2, + (disjoint (inst_frame i) wframe) -> + (forall x, notIn x wframe -> old1 x = old2 x) -> + (forall x, notIn x wframe -> tmp1 x = tmp2 x) -> + inst_prun ge i m tmp1 old1 = inst_prun ge i m tmp2 old2. +Proof. + induction i as [|[x e] i']; simpl; auto. + intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. + intros (H1 & H2 & H3) H6 H7. + cutrewrite (exp_eval ge e tmp1 old1 = exp_eval ge e tmp2 old2). + - destruct (exp_eval ge e tmp2 old2); auto. + eapply IHi'; eauto. + simpl; intros x0 H0; unfold assign. destruct (R.eq_dec x x0); simpl; auto. + - unfold disjoint in H2; apply exp_frame_correct. + intros;apply H6; auto. + intros;apply H7; auto. +Qed. + +(** * Parallelizability *) + +Fixpoint pararec (p: bblock) (wframe: list R.t): Prop := + match p with + | nil => True + | i::p' => + disjoint (inst_frame i) wframe (* no USE-AFTER-WRITE *) + /\ pararec p' ((inst_wframe i) ++ wframe) + end. + +Lemma pararec_disjoint (p: bblock): forall wframe, pararec p wframe -> disjoint (bblock_wframe p) wframe. +Proof. + induction p as [|i p']; simpl. + - unfold disjoint; simpl; intuition. + - intros wframe [H0 H1]; rewrite disjoint_app_l. + generalize (IHp' _ H1). + rewrite disjoint_app_r. intuition. + eapply disjoint_incl_l. 2: eapply H0. + unfold incl. eapply inst_wframe_frame; eauto. +Qed. + +Lemma pararec_det p: forall wframe, pararec p wframe -> is_det p. +Proof. + induction p as [|i p']; simpl; auto. + intros wframe [H0 H1]. generalize (pararec_disjoint _ _ H1). rewrite disjoint_app_r. + intuition. + - apply disjoint_sym; auto. + - eapply IHp'. eauto. +Qed. + +Lemma pararec_correct p old: forall wframe m, + pararec p wframe -> + (forall x, notIn x wframe -> m x = old x) -> + run ge p m = prun_iw ge p m old. +Proof. + elim p; clear p; simpl; auto. + intros i p' X wframe m [H H0] H1. + erewrite inst_run_prun, inst_frame_correct; eauto. + remember (inst_prun ge i m old old) as om0. + destruct om0 as [m0 | ]; try congruence. + eapply X; eauto. + intro x; rewrite notIn_app. intros [H3 H4]. + rewrite <- H1; auto. + eapply inst_wframe_correct; eauto. +Qed. + +Definition parallelizable (p: bblock) := pararec p nil. + +Theorem parallelizable_correct p m om': + parallelizable p -> (prun ge p m om' <-> res_eq om' (run ge p m)). +Proof. + intros H. constructor 1. + - intros (p' & H0 & H1). eapply res_eq_trans; eauto. + erewrite pararec_correct; eauto. + eapply res_eq_sym. + eapply is_det_correct; eauto. + eapply pararec_det; eauto. + - intros; unfold prun. + eexists. constructor 1. 2: apply Permutation_refl. + erewrite pararec_correct in H0; eauto. +Qed. + +End PARALLELI. + +End ParallelizablityChecking. + + +Module Type PseudoRegSet. + +Declare Module R: PseudoRegisters. + +(** We assume a datatype [t] refining (list R.t) + +This data-refinement is given by an abstract "invariant" match_frame below, +preserved by the following operations. + +*) + +Parameter t: Type. +Parameter match_frame: t -> (list R.t) -> Prop. + +Parameter empty: t. +Parameter empty_match_frame: match_frame empty nil. + +Parameter add: R.t -> t -> t. +Parameter add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). + +Parameter union: t -> t -> t. +Parameter union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). + +Parameter is_disjoint: t -> t -> bool. +Parameter is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. + +End PseudoRegSet. + + +Lemma lazy_andb_bool_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. +Proof. + destruct b1, b2; intuition. +Qed. + + + + +Module ParallelChecks (L: SeqLanguage) (S:PseudoRegSet with Module R:=L.LP.R). + +Include ParallelizablityChecking L. + +Section PARALLEL2. +Variable ge: genv. + +Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core. + +(** Now, refinement of each operation toward parallelizable *) + +Fixpoint inst_wsframe(i:inst): S.t := + match i with + | nil => S.empty + | a::i' => S.add (fst a) (inst_wsframe i') + end. + +Lemma inst_wsframe_correct i: S.match_frame (inst_wsframe i) (inst_wframe i). +Proof. + induction i; simpl; auto. +Qed. + +Fixpoint exp_sframe (e: exp): S.t := + match e with + | PReg x => S.add x S.empty + | Op o le => list_exp_sframe le + | Old e => exp_sframe e + end +with list_exp_sframe (le: list_exp): S.t := + match le with + | Enil => S.empty + | Econs e le' => S.union (exp_sframe e) (list_exp_sframe le') + | LOld le => list_exp_sframe le + end. + +Lemma exp_sframe_correct e: S.match_frame (exp_sframe e) (exp_frame e). +Proof. + induction e using exp_mut with (P0:=fun l => S.match_frame (list_exp_sframe l) (list_exp_frame l)); simpl; auto. +Qed. + +Fixpoint inst_sframe (i: inst): S.t := + match i with + | nil => S.empty + | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) + end. + +Local Hint Resolve exp_sframe_correct: core. + +Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i). +Proof. + induction i as [|[y e] i']; simpl; auto. +Qed. + +Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core. + +Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := + match p with + | nil => true + | i::p' => + S.is_disjoint (inst_sframe i) wsframe (* no USE-AFTER-WRITE *) + &&& is_pararec p' (S.union (inst_wsframe i) wsframe) + end. + +Lemma is_pararec_correct (p: bblock): forall s l, S.match_frame s l -> (is_pararec p s)=true -> (pararec p l). +Proof. + induction p; simpl; auto. + intros s l H1 H2; rewrite lazy_andb_bool_true in H2. destruct H2 as [H2 H3]. + constructor 1; eauto. +Qed. + +Definition is_parallelizable (p: bblock) := is_pararec p S.empty. + +Lemma is_para_correct_aux p: is_parallelizable p = true -> parallelizable p. +Proof. + unfold is_parallelizable, parallelizable; intros; eapply is_pararec_correct; eauto. +Qed. + +Theorem is_parallelizable_correct p: + is_parallelizable p = true -> forall m om', (prun ge p m om' <-> res_eq om' (run ge p m)). +Proof. + intros; apply parallelizable_correct. + apply is_para_correct_aux. auto. +Qed. + +End PARALLEL2. +End ParallelChecks. + + + + +Require Import PArith. +Require Import MSets.MSetPositive. + +Module PosPseudoRegSet <: PseudoRegSet with Module R:=Pos. + +Module R:=Pos. + +(** We assume a datatype [t] refining (list R.t) + +This data-refinement is given by an abstract "invariant" match_frame below, +preserved by the following operations. + +*) + +Definition t:=PositiveSet.t. + +Definition match_frame (s:t) (l:list R.t): Prop + := forall x, PositiveSet.In x s <-> In x l. + +Definition empty:=PositiveSet.empty. + +Lemma empty_match_frame: match_frame empty nil. +Proof. + unfold match_frame, empty, PositiveSet.In; simpl; intuition. +Qed. + +Definition add: R.t -> t -> t := PositiveSet.add. + +Lemma add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). +Proof. + unfold match_frame, add; simpl. + intros s x l H y. rewrite PositiveSet.add_spec, H. + intuition. +Qed. + +Definition union: t -> t -> t := PositiveSet.union. +Lemma union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). +Proof. + unfold match_frame, union. + intros s1 s2 l1 l2 H1 H2 x. rewrite PositiveSet.union_spec, H1, H2. + intuition. +Qed. + +Fixpoint is_disjoint (s s': PositiveSet.t) : bool := + match s with + | PositiveSet.Leaf => true + | PositiveSet.Node l o r => + match s' with + | PositiveSet.Leaf => true + | PositiveSet.Node l' o' r' => + if (o &&& o') then false else (is_disjoint l l' &&& is_disjoint r r') + end + end. + +Lemma is_disjoint_spec_true s: forall s', is_disjoint s s' = true -> forall x, PositiveSet.In x s -> PositiveSet.In x s' -> False. +Proof. + unfold PositiveSet.In; induction s as [ |l IHl o r IHr]; simpl; try discriminate. + destruct s' as [|l' o' r']; simpl; try discriminate. + intros X. + assert (H: ~(o = true /\ o'=true) /\ is_disjoint l l' = true /\ is_disjoint r r'=true). + { destruct o, o', (is_disjoint l l'), (is_disjoint r r'); simpl in X; intuition. } + clear X; destruct H as (H & H1 & H2). + destruct x as [i|i|]; simpl; eauto. +Qed. + +Lemma is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. +Proof. + unfold match_frame, disjoint. + intros s1 s2 l1 l2 H1 H2 H3 x. + rewrite <- notIn_iff, <- H1, <- H2. + intros H4 H5; eapply is_disjoint_spec_true; eauto. +Qed. + +End PosPseudoRegSet. diff --git a/kvx/abstractbb/README.md b/kvx/abstractbb/README.md new file mode 100644 index 00000000..69e5defc --- /dev/null +++ b/kvx/abstractbb/README.md @@ -0,0 +1,12 @@ +# Coq sources of AbstractBasicBlocks + +- [AbstractBasicBlocksDef](AbstractBasicBlocksDef.v): syntax and sequential semantics of abstract basic blocks (on which we define our analyzes). +This syntax and semantics is parametrized in order to adapt the language for different concrete basic block languages. + +- [Parallelizability](Parallelizability.v): define the parallel semantics and the 'is_parallelizable' function which tests whether the sequential run of a given abstract basic block is the same than a parallel run. + +- [DepTreeTheory](DepTreeTheory.v): defines a theory of dependency trees, such that two basic blocks with the same dependency tree have the same sequential semantics. In practice, permuting the instructions inside a basic block while perserving the dependencies of assignments should not change the dependency tree. The idea is to verify list schedulings, following ideas of [Formal verification of translation validators proposed by Tristan and Leroy](https://hal.inria.fr/inria-00289540/). + +- [ImpDep](ImpDep.v): adds a hash-consing mechanism to trees of [DepTreeTheory](DepTreeTheory.v), and thus provides an efficient "equality" test (a true answer ensures that the two basic blocks in input have the same sequential semantics) in order to check the correctness of list schedulings. + +- [DepExample](DepExample.v) defines a toy language (syntax and semantics); [DepExampleEqTest](DepExampleEqTest.v) defines a compiler of the toy language into abstract basic blocks and derives an equality test for the toy language; [DepExampleParallelTest](DepExampleParallelTest.v) derives a parallelizability test from the previous compiler; [DepExampleDemo](DepExampleDemo.v) is a test-suite for both tetsts. diff --git a/kvx/abstractbb/SeqSimuTheory.v b/kvx/abstractbb/SeqSimuTheory.v new file mode 100644 index 00000000..61f8f2ec --- /dev/null +++ b/kvx/abstractbb/SeqSimuTheory.v @@ -0,0 +1,396 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* *) +(* Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** A theory for checking/proving simulation by symbolic execution. + +*) + + +Require Coq.Logic.FunctionalExtensionality. (* not really necessary -- see lemma at the end *) +Require Setoid. (* in order to rewrite <-> *) +Require Export AbstractBasicBlocksDef. +Require Import List. +Require Import ImpPrelude. +Import HConsingDefs. + + +Module SimuTheory (L: SeqLanguage). + +Export L. +Export LP. + +Inductive term := + | Input (x:R.t) + | App (o: op) (l: list_term) +with list_term := + | LTnil + | LTcons (t:term) (l:list_term) + . + +Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := + match t with + | Input x => Some (m x) + | App o l => + match list_term_eval ge l m with + | Some v => op_eval ge o v + | _ => None + end + end +with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := + match l with + | LTnil => Some nil + | LTcons t l' => + match term_eval ge t m, list_term_eval ge l' m with + | Some v, Some lv => Some (v::lv) + | _, _ => None + end + end. + +(* the symbolic memory: + - pre: pre-condition expressing that the computation has not yet abort on a None. + - post: the post-condition for each pseudo-register +*) +Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}. + +(** initial symbolic memory *) +Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}. + +Fixpoint exp_term (e: exp) (d old: smem) : term := + match e with + | PReg x => d x + | Op o le => App o (list_exp_term le d old) + | Old e => exp_term e old old + end +with list_exp_term (le: list_exp) (d old: smem) : list_term := + match le with + | Enil => LTnil + | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) + | LOld le => list_exp_term le old old + end. + + +(** assignment of the symbolic memory *) +Definition smem_set (d:smem) x (t:term) := + {| pre:=(fun ge m => (term_eval ge (d x) m) <> None /\ (d.(pre) ge m)); + post:=fun y => if R.eq_dec x y then t else d y |}. + +Section SIMU_THEORY. + +Variable ge: genv. + +Lemma set_spec_eq d x t m: + term_eval ge (smem_set d x t x) m = term_eval ge t m. +Proof. + unfold smem_set; simpl; case (R.eq_dec x x); try congruence. +Qed. + +Lemma set_spec_diff d x y t m: + x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m. +Proof. + unfold smem_set; simpl; case (R.eq_dec x y); try congruence. +Qed. + +Fixpoint inst_smem (i: inst) (d old: smem): smem := + match i with + | nil => d + | (x, e)::i' => + let t:=exp_term e d old in + inst_smem i' (smem_set d x t) old + end. + +Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := + match p with + | nil => d + | i::p' => + let d':=inst_smem i d d in + bblock_smem_rec p' d' + end. + +Definition bblock_smem: bblock -> smem + := fun p => bblock_smem_rec p smem_empty. + +Lemma inst_smem_pre_monotonic i old: forall d m, + (pre (inst_smem i d old) ge m) -> (pre d ge m). +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d a H; generalize (IHi _ _ H); clear H IHi. + unfold smem_set; simpl; intuition. +Qed. + +Lemma bblock_smem_pre_monotonic p: forall d m, + (pre (bblock_smem_rec p d) ge m) -> (pre d ge m). +Proof. + induction p as [|i p' IHp']; simpl; eauto. + intros d a H; eapply inst_smem_pre_monotonic; eauto. +Qed. + +Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core. + +Lemma term_eval_exp e (od:smem) m0 old: + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (d:smem) m1, + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. +Proof. + intro H. + induction e using exp_mut with + (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); + simpl; auto. + - intros; erewrite IHe; eauto. + - intros. erewrite IHe, IHe0; eauto. +Qed. + +Lemma inst_smem_abort i m0 x old: forall (d:smem), + pre (inst_smem i d old) ge m0 -> + term_eval ge (d x) m0 = None -> + term_eval ge (inst_smem i d old x) m0 = None. +Proof. + induction i as [|[y e] i IHi]; simpl; auto. + intros d VALID H; erewrite IHi; eauto. clear IHi. + unfold smem_set; simpl; destruct (R.eq_dec y x); auto. + subst; + generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. + unfold smem_set; simpl. intuition congruence. +Qed. + +Lemma block_smem_rec_abort p m0 x: forall d, + pre (bblock_smem_rec p d) ge m0 -> + term_eval ge (d x) m0 = None -> + term_eval ge (bblock_smem_rec p d x) m0 = None. +Proof. + induction p; simpl; auto. + intros d VALID H; erewrite IHp; eauto. clear IHp. + eapply inst_smem_abort; eauto. +Qed. + +Lemma inst_smem_Some_correct1 i m0 old (od:smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + inst_run ge i m1 old = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x). +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. + refine (IHi _ _ _ _ _ _); eauto. + clear x0; intros x0. + unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. +Qed. + +Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), + run ge p m1 = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). +Proof. + Local Hint Resolve inst_smem_Some_correct1: core. + induction p as [ | i p]; simpl; intros m1 m2 d H. + - inversion_clear H; eauto. + - intros H0 x0. + destruct (inst_run ge i m1 m1) eqn: Heqov. + + refine (IHp _ _ _ _ _ _); eauto. + + inversion H. +Qed. + +Lemma bblock_smem_Some_correct1 p m0 m1: + run ge p m0 = Some m1 + -> forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x). +Proof. + intros; eapply bblocks_smem_rec_Some_correct1; eauto. +Qed. + +Lemma inst_smem_None_correct i m0 old (od: smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall m1 d, pre (inst_smem i d od) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + inst_run ge i m1 old = None -> exists x, term_eval ge (inst_smem i d od x) m0 = None. +Proof. + intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. + - discriminate. + - intros VALID H0. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _); eauto. + intros x0; unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + + intuition. + constructor 1 with (x:=x); simpl. + apply inst_smem_abort; auto. + rewrite set_spec_eq. + erewrite term_eval_exp; eauto. +Qed. + +Lemma inst_smem_Some_correct2 i m0 old (od: smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) d, + pre (inst_smem i d od) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x)) -> + res_eq (Some m2) (inst_run ge i m1 old). +Proof. + intro X. + induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (exp_eval ge e m1 old) eqn: Heqov. + + refine (IHi _ _ _ _ _ _); eauto. + intros x0; unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. + + generalize (H x). + rewrite inst_smem_abort; discriminate || auto. + rewrite set_spec_eq. + erewrite term_eval_exp; eauto. +Qed. + +Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d, + pre (bblock_smem_rec p d) ge m0 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + (forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x)) -> + res_eq (Some m2) (run ge p m1). +Proof. + induction p as [|i p]; simpl; intros m1 m2 d VALID H0. + - intros H; eapply ex_intro; intuition eauto. + generalize (H0 x); rewrite H. + congruence. + - intros H. + destruct (inst_run ge i m1 m1) eqn: Heqom. + + refine (IHp _ _ _ _ _ _); eauto. + + assert (X: exists x, term_eval ge (inst_smem i d d x) m0 = None). + { eapply inst_smem_None_correct; eauto. } + destruct X as [x H1]. + generalize (H x). + erewrite block_smem_rec_abort; eauto. + congruence. +Qed. + +Lemma bblock_smem_Some_correct2 p m0 m1: + pre (bblock_smem p) ge m0 -> + (forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x)) + -> res_eq (Some m1) (run ge p m0). +Proof. + intros; eapply bblocks_smem_rec_Some_correct2; eauto. +Qed. + +Lemma inst_valid i m0 old (od:smem): + (forall x, term_eval ge (od x) m0 = Some (old x)) -> + forall (m1 m2: mem) (d: smem), + pre d ge m0 -> + inst_run ge i m1 old = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + pre (inst_smem i d od) ge m0. +Proof. + induction i as [|[x e] i IHi]; simpl; auto. + intros Hold m1 m2 d VALID0 H Hm1. + destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. + eapply IHi; eauto. + + unfold smem_set in * |- *; simpl. + rewrite Hm1; intuition congruence. + + intros x0. unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. + subst; erewrite term_eval_exp; eauto. +Qed. + + +Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), + pre d ge m0 -> + run ge p m1 = Some m2 -> + (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> + pre (bblock_smem_rec p d) ge m0. +Proof. + Local Hint Resolve inst_valid: core. + induction p as [ | i p]; simpl; intros m1 d H; auto. + intros H0 H1. + destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. + congruence. +Qed. + +Lemma bblock_smem_valid p m0 m1: + run ge p m0 = Some m1 -> + pre (bblock_smem p) ge m0. +Proof. + intros; eapply block_smem_rec_valid; eauto. + unfold smem_empty; simpl. auto. +Qed. + +Definition smem_valid ge d m := pre d ge m /\ forall x, term_eval ge (d x) m <> None. + +Definition smem_simu (d1 d2: smem): Prop := + (forall m, smem_valid ge d1 m -> smem_valid ge d2 m) + /\ (forall m0 x, smem_valid ge d1 m0 -> + term_eval ge (d1 x) m0 = term_eval ge (d2 x) m0). + + +Theorem bblock_smem_simu p1 p2: + smem_simu (bblock_smem p1) (bblock_smem p2) -> + bblock_simu ge p1 p2. +Proof. + Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core. + intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. + destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. + assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. + eapply bblock_smem_Some_correct2; eauto. + + destruct (INCL m); intuition eauto. + congruence. + + intro x; erewrite <- EQUIV; intuition eauto. + congruence. +Qed. + +Lemma smem_valid_set_decompose_1 d t x m: + smem_valid ge (smem_set d x t) m -> smem_valid ge d m. +Proof. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID); split. + + intuition. + + intros x0 H. case (R.eq_dec x x0). + * intuition congruence. + * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. +Qed. + +Lemma smem_valid_set_decompose_2 d t x m: + smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None. +Proof. + unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. + generalize (VALID x); rewrite set_spec_eq. + tauto. +Qed. + +Lemma smem_valid_set_proof d x t m: + smem_valid ge d m -> term_eval ge t m <> None -> smem_valid ge (smem_set d x t) m. +Proof. + unfold smem_valid; intros (PRE & VALID) PREt. split. + + split; auto. + + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto. +Qed. + + +End SIMU_THEORY. + +(** REMARKS: more abstract formulation of the proof... + but relying on functional_extensionality. +*) +Definition smem_correct ge (d: smem) (m: mem) (om: option mem): Prop:= + forall m', om=Some m' <-> (d.(pre) ge m /\ forall x, term_eval ge (d x) m = Some (m' x)). + +Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m). +Proof. + unfold smem_correct; simpl; intros m'; split. + + intros; split. + * eapply bblock_smem_valid; eauto. + * eapply bblock_smem_Some_correct1; eauto. + + intros (H1 & H2). + destruct (bblock_smem_Some_correct2 ge p m m') as (m2 & X & Y); eauto. + rewrite X. f_equal. + apply FunctionalExtensionality.functional_extensionality; auto. +Qed. + +End SimuTheory. diff --git a/kvx/bitmasks.py b/kvx/bitmasks.py new file mode 100755 index 00000000..9f6987d6 --- /dev/null +++ b/kvx/bitmasks.py @@ -0,0 +1,12 @@ +#!/usr/bin/env python3 +def bitmask(to, fr): + bit_to = 1< " Configuration.model = ""64"" ". +Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) + +Extract Constant Peephole.print_found_store => +"fun offset x -> Printf.printf ""found offset = %ld\n"" (Camlcoq.camlint_of_coqint offset); x". + +(* Asm *) +(* +Extract Constant Asm.low_half => "fun _ _ _ -> assert false". +Extract Constant Asm.high_half => "fun _ _ _ -> assert false". +*) diff --git a/kvx/lib/Asmblockgenproof0.v b/kvx/lib/Asmblockgenproof0.v new file mode 100644 index 00000000..1af59238 --- /dev/null +++ b/kvx/lib/Asmblockgenproof0.v @@ -0,0 +1,982 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* Xavier Leroy INRIA Paris-Rocquencourt *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(** * "block" version of Asmgenproof0 + + This module is largely adapted from Asmgenproof0.v of the other backends + It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends + It has similar definitions than Asmgenproof0, but adapted to this new structure *) + +Require Import Coqlib. +Require Intv. +Require Import AST. +Require Import Errors. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Locations. +Require Import Machblock. +Require Import Asmblock. +Require Import Asmblockgen. +Require Import Conventions1. +Require Import Axioms. +Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) +Require Import Asmblockprops. + +Module MB:=Machblock. +Module AB:=Asmblock. + +Lemma ireg_of_eq: + forall r r', ireg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold ireg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma freg_of_eq: + forall r r', freg_of r = OK r' -> preg_of r = IR r'. +Proof. + unfold freg_of; intros. destruct (preg_of r); inv H; auto. +Qed. + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +Lemma undef_regs_other: + forall r rl rs, + (forall r', In r' rl -> r <> r') -> + undef_regs rl rs r = rs r. +Proof. + induction rl; simpl; intros. auto. + rewrite IHrl by auto. rewrite Pregmap.gso; auto. +Qed. + +Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := + match rl with + | nil => True + | r1 :: nil => r <> preg_of r1 + | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl + end. + +Remark preg_notin_charact: + forall r rl, + preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). +Proof. + induction rl; simpl; intros. + tauto. + destruct rl. + simpl. split. intros. intuition congruence. auto. + rewrite IHrl. split. + intros [A B]. intros. destruct H. congruence. auto. + auto. +Qed. + +Lemma undef_regs_other_2: + forall r rl rs, + preg_notin r rl -> + undef_regs (map preg_of rl) rs r = rs r. +Proof. + intros. apply undef_regs_other. intros. + exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. + rewrite preg_notin_charact in H. auto. +Qed. + +(** * Agreement between Mach registers and processor registers *) + +Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { + agree_sp: rs#SP = sp; + agree_sp_def: sp <> Vundef; + agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) +}. + +Lemma preg_val: + forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). +Proof. + intros. destruct H. auto. +Qed. + +Lemma preg_vals: + forall ms sp rs, agree ms sp rs -> + forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). +Proof. + induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, agree ms sp rs -> sp = rs#SP. +Proof. + intros. destruct H; auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r r', + agree ms sp rs -> + ireg_of r = OK r' -> + Val.lessdef (ms r) rs#r'. +Proof. + intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma freg_val: + forall ms sp rs r r', + agree ms sp rs -> + freg_of r = OK r' -> + Val.lessdef (ms r) (rs#r'). +Proof. + intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. +Qed. + +Lemma agree_exten: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, data_preg r = true -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H0; auto. auto. + intros. rewrite H0; auto. apply preg_of_data. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. + intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. + rewrite H1. auto. apply preg_of_data. + red; intros; elim n. eapply preg_of_injective; eauto. +Qed. + +Corollary agree_set_mreg_parallel: + forall ms sp rs r v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). +Proof. + intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. +Qed. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + data_preg r = false -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten with rs. auto. + intros. apply Pregmap.gso. congruence. +Qed. + +Lemma agree_nextblock: + forall ms sp rs b, + agree ms sp rs -> agree ms sp (nextblock b rs). +Proof. + intros. unfold nextblock. apply agree_set_other. auto. auto. +Qed. + +Lemma agree_set_pair: + forall sp p v v' ms rs, + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). +Proof. + intros. destruct p; simpl. +- apply agree_set_mreg_parallel; auto. +- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. + apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. +Qed. + +Lemma agree_undef_nondata_regs: + forall ms sp rl rs, + agree ms sp rs -> + (forall r, In r rl -> data_preg r = false) -> + agree ms sp (undef_regs rl rs). +Proof. + induction rl; simpl; intros. auto. + apply IHrl. apply agree_exten with rs; auto. + intros. apply Pregmap.gso. red; intros; subst. + assert (data_preg a = false) by auto. congruence. + intros. apply H0; auto. +Qed. + +Lemma agree_undef_regs: + forall ms sp rl rs rs', + agree ms sp rs -> + (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.undef_regs rl ms) sp rs'. +Proof. + intros. destruct H. split; auto. + rewrite <- agree_sp0. apply H0; auto. + rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. + intros. destruct (In_dec mreg_eq r rl). + rewrite Mach.undef_regs_same; auto. + rewrite Mach.undef_regs_other; auto. rewrite H0; auto. + apply preg_of_data. + rewrite preg_notin_charact. intros; red; intros. elim n. + exploit preg_of_injective; eauto. congruence. +Qed. + +Lemma agree_set_undef_mreg: + forall ms sp rs r v rl rs', + agree ms sp rs -> + Val.lessdef v (rs'#(preg_of r)) -> + (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> + agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. +Proof. + intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. + apply agree_undef_regs with rs; auto. + intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). + congruence. auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma agree_undef_caller_save_regs: + forall ms sp rs, + agree ms sp rs -> + agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). +Proof. + intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. +- unfold proj_sumbool; rewrite dec_eq_true. auto. +- auto. +- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). + destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. ++ apply list_in_map_inv in i. destruct i as (mr & A & B). + assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. + apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. ++ destruct (is_callee_save r) eqn:CS; auto. + elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. +Qed. + +Lemma agree_change_sp: + forall ms sp rs sp', + agree ms sp rs -> sp' <> Vundef -> + agree ms sp' (rs#SP <- sp'). +Proof. + intros. inv H. split; auto. + intros. rewrite Pregmap.gso; auto with asmgen. +Qed. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m m' l v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg ms m sp l v -> + exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. + exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. + unfold Mach.load_stack in H2. + exploit Mem.loadv_extends; eauto. intros [v' [A B]]. + rewrite (sp_val _ _ _ H) in A. + exists v'; split; auto. + econstructor. eauto. assumption. +Qed. + +Lemma extcall_arg_pair_match: + forall ms sp rs m m' p v, + agree ms sp rs -> + Mem.extends m m' -> + Mach.extcall_arg_pair ms m sp p v -> + exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. +Proof. + intros. inv H1. +- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. +- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). + exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). + exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. +Qed. + + +Lemma extcall_args_match: + forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall ll vl, + list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> + exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros. + exists (@nil val); split. constructor. constructor. + exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. +Qed. + +Lemma extcall_arguments_match: + forall ms m m' sp rs sg args, + agree ms sp rs -> Mem.extends m m' -> + Mach.extcall_arguments ms m sp sg args -> + exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. +Proof. + unfold Mach.extcall_arguments, AB.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +Remark builtin_arg_match: + forall ge (rs: regset) sp m a v, + eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> + eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. +Proof. + induction 1; simpl; eauto with barg. +Qed. + +Lemma builtin_args_match: + forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> + forall al vl, eval_builtin_args ge ms sp m al vl -> + exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' + /\ Val.lessdef_list vl vl'. +Proof. + induction 3; intros; simpl. + exists (@nil val); split; constructor. + exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. + intros; eapply preg_val; eauto. + intros (v1' & A & B). + destruct IHlist_forall2 as [vl' [C D]]. + exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. +Qed. + +Lemma agree_set_res: + forall res ms sp rs v v', + agree ms sp rs -> + Val.lessdef v v' -> + agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). +Proof. + induction res; simpl; intros. +- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. + intros. apply Pregmap.gso; auto. +- auto. +- apply IHres2. apply IHres1. auto. + apply Val.hiword_lessdef; auto. + apply Val.loword_lessdef; auto. +Qed. + +Lemma set_res_other: + forall r res v rs, + data_preg r = false -> + set_res (map_builtin_res preg_of res) v rs r = rs r. +Proof. + induction res; simpl; intros. +- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. +- auto. +- rewrite IHres2, IHres1; auto. +Qed. + +(* inspired from Mach *) + +Lemma find_label_tail: + forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. + +(* inspired from Asmgenproof0 *) + +(* ... skip ... *) + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> bblocks -> bblocks -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos bi c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + (size bi)) (bi :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. generalize (size_positive bi); intros; omega. +Qed. + +Lemma find_bblock_tail: + forall c1 bi c2 pos, + code_tail pos c1 (bi :: c2) -> + find_bblock pos c1 = Some bi. +Proof. + induction c1; simpl; intros. + inversion H. + destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. + inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. + eauto. +Qed. + + +Local Hint Resolve code_tail_0 code_tail_S: core. + +Lemma code_tail_next: + forall fn ofs c0, + code_tail ofs fn c0 -> + forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. +Proof. + induction 1; intros. + - subst; eauto. + - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. + omega. +Qed. + +Lemma size_blocks_pos c: 0 <= size_blocks c. +Proof. + induction c as [| a l ]; simpl; try omega. + generalize (size_positive a); omega. +Qed. + +Remark code_tail_positive: + forall fn ofs c, + code_tail ofs fn c -> 0 <= ofs. +Proof. + induction 1; intros; simpl. + - omega. + - generalize (size_positive bi). omega. +Qed. + +Remark code_tail_size: + forall fn ofs c, + code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. +Proof. + induction 1; intros; simpl; try omega. +Qed. + +Remark code_tail_bounds fn ofs c: + code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. +Proof. + intro H; + exploit code_tail_size; eauto. + generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). + omega. +Qed. + +Local Hint Resolve code_tail_next: core. + +Lemma code_tail_next_int: + forall fn ofs bi c, + size_blocks fn <= Ptrofs.max_unsigned -> + code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> + code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. +Proof. + intros. + exploit code_tail_size; eauto. + simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). + intros. + rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. + - rewrite Ptrofs.unsigned_repr; eauto. + omega. + - rewrite Ptrofs.unsigned_repr; omega. +Qed. + +(** Predictor for return addresses in generated Asm code. + + The [return_address_offset] predicate defined here is used in the + semantics for Mach to determine the return addresses that are + stored in activation records. *) + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the Asm code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + Asm code | |--------| + Asm function |------------- Pcall ---------| + + <-------- ofs -------> +>> +*) + +Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := + forall tf tc, + transf_function f = OK tf -> + transl_blocks f c false = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. + +Lemma transl_blocks_tail: + forall f c1 c2, is_tail c1 c2 -> + forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> + exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. +Proof. + induction 1; simpl; intros. + exists tc2; exists ep2; split; auto with coqlib. + monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). + exists tc1; exists ep1; split. auto. + eapply is_tail_trans with x0; eauto with coqlib. +Qed. + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1; eauto. + destruct IHis_tail; eauto. +Qed. + +Section RETADDR_EXISTS. + +Hypothesis transf_function_inv: + forall f tf, transf_function f = OK tf -> + exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). + +Hypothesis transf_function_len: + forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. + + +Lemma return_address_exists: + forall b f c, is_tail (b :: c) f.(MB.fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. destruct (transf_function f) as [tf|] eqn:TF. + + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). + exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). + monadInv TR2. + assert (TL3: is_tail x0 (fn_blocks tf)). + { apply is_tail_trans with tc1; auto. + apply is_tail_trans with (x++x0); auto. eapply is_tail_app. + } + exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. + exists (Ptrofs.repr ofs). red; intros. + rewrite Ptrofs.unsigned_repr. congruence. + exploit code_tail_bounds; eauto. + intros; apply transf_function_len in TF. omega. + + exists Ptrofs.zero; red; intros. congruence. +Qed. + +End RETADDR_EXISTS. + +(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points + within the Asmblock code generated by translating Machblock function [f], + and [tc] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +Inductive transl_code_at_pc (ge: MB.genv): + val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := + transl_code_at_pc_intro: + forall b ofs f c ep tf tc, + Genv.find_funct_ptr ge b = Some(Internal f) -> + transf_function f = Errors.OK tf -> + transl_blocks f c ep = OK tc -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> + transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall ge b ofs fb f c tf tc ofs', + transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H. red in H0. + exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. + rewrite <- (Ptrofs.repr_unsigned ofs). + rewrite <- (Ptrofs.repr_unsigned ofs'). + congruence. +Qed. + +(** The [find_label] function returns the code tail starting at the + given label. A connection with [code_tail] is then established. *) + +Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos <= pos' <= pos + size_blocks c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + - intros. inv H. exists pos. split; auto. split. + replace (pos - pos) with 0 by omega. constructor. constructor; try omega. + generalize (size_blocks_pos c). generalize (size_positive a). omega. + - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. + exists pos'. split. auto. split. + replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. + constructor. auto. generalize (size_positive a). omega. +Qed. + +(** Helper lemmas to reason about +- the "code is tail of" property +- correct translation of labels. *) + +Definition tail_nolabel (k c: bblocks) : Prop := + is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. + +Lemma tail_nolabel_refl: + forall c, tail_nolabel c c. +Proof. + intros; split. apply is_tail_refl. auto. +Qed. + +Lemma tail_nolabel_trans: + forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. +Proof. + intros. destruct H; destruct H0; split. + eapply is_tail_trans; eauto. + intros. rewrite H1; auto. +Qed. + +Definition nolabel (b: bblock) := + match (header b) with nil => True | _ => False end. + +Hint Extern 1 (nolabel _) => exact I : labels. + +Lemma tail_nolabel_cons: + forall b c k, + nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). +Proof. + intros. destruct H0. split. + constructor; auto. + intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. + destruct hd as [|l hd]; simpl in *. + - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). + { apply is_label_correct_false. simpl header. apply in_nil. } + rewrite H2. auto. + - contradiction. +Qed. + +Hint Resolve tail_nolabel_refl: labels. + +Ltac TailNoLabel := + eauto with labels; + match goal with + | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] + | [ H: Error _ = OK _ |- _ ] => discriminate + | [ H: assertion_failed = OK _ |- _ ] => discriminate + | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel + | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel + | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel + | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel + | _ => idtac + end. + +Remark tail_nolabel_find_label: + forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. +Proof. + intros. destruct H. auto. +Qed. + +Remark tail_nolabel_is_tail: + forall k c, tail_nolabel k c -> is_tail k c. +Proof. + intros. destruct H. auto. +Qed. + +Lemma exec_body_pc: + forall ge l rs1 m1 rs2 m2, + exec_body ge l rs1 m1 = Next rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction l. + - intros. inv H. auto. + - intros until m2. intro EXEB. + inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. + eapply IHl in H0. rewrite H0. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: function. + +(** Straight-line code is composed of processor instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: list instruction -> regset -> mem -> + list instruction -> regset -> mem -> Prop := + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 + | exec_straight_step: + forall i c rs1 m1 rs2 m2 c' rs3 m3, + exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. + +Inductive exec_control_rel: option control -> bblock -> regset -> mem -> + regset -> mem -> Prop := + | exec_control_rel_intro: + forall rs1 m1 b rs1' ctl rs2 m2, + rs1' = nextblock b rs1 -> + exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> + exec_control_rel ctl b rs1 m1 rs2 m2. + +Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := + | exec_bblock_rel_intro: + forall rs1 m1 b rs2 m2, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + exec_bblock_rel b rs1 m1 rs2 m2. + +Lemma exec_straight_body: + forall c l rs1 m1 rs2 m2, + exec_straight c rs1 m1 nil rs2 m2 -> + code_to_basics c = Some l -> + exec_body ge l rs1 m1 = Next rs2 m2. +Proof. + induction c as [|i c]. + - intros until m2. intros EXES CTB. inv EXES. + - intros until m2. intros EXES CTB. inv EXES. + + inv CTB. simpl. rewrite H6. auto. + + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. + rewrite <- H7. simpl. rewrite H1. auto. +Qed. + +Lemma exec_straight_body2: + forall c rs1 m1 c' rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + exists body, + exec_body ge body rs1 m1 = Next rs2 m2 + /\ (basics_to_code body) ++g c' = c. +Proof. + intros until m2. induction 1. + - exists (i1::nil). split; auto. simpl. rewrite H. auto. + - destruct IHexec_straight as (bdy & EXEB & BTC). + exists (i:: bdy). split; simpl. + + rewrite H. auto. + + congruence. +Qed. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> + exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> + exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> + exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** Like exec_straight predicate, but on blocks *) + +Inductive exec_straight_blocks: bblocks -> regset -> mem -> + bblocks -> regset -> mem -> Prop := + | exec_straight_blocks_one: + forall b1 c rs1 m1 rs2 m2, + exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> + exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 + | exec_straight_blocks_step: + forall b c rs1 m1 rs2 m2 c' rs3 m3, + exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> + rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> + exec_straight_blocks c rs2 m2 c' rs3 m3 -> + exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_blocks_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> + exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> + exec_straight_blocks c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_blocks_step with rs2 m2; auto. + apply exec_straight_blocks_step with rs2 m2; auto. +Qed. + +(** Linking exec_straight with exec_straight_blocks *) + +Lemma exec_straight_pc: + forall c c' rs1 m1 rs2 m2, + exec_straight c rs1 m1 c' rs2 m2 -> + rs2 PC = rs1 PC. +Proof. + induction c; intros; try (inv H; fail). + inv H. + - eapply exec_basic_instr_pc; eauto. + - rewrite (IHc c' rs3 m3 rs2 m2); auto. + erewrite exec_basic_instr_pc; eauto. +Qed. + +Lemma regset_same_assign (rs: regset) r: + rs # r <- (rs r) = rs. +Proof. + apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. +Qed. + +Lemma exec_straight_through_singleinst: + forall a b rs1 m1 rs2 m2 rs2' m2' lb, + bblock_single_inst (PBasic a) = b -> + exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> + nextblock b rs2 = rs2' -> m2 = m2' -> + exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. +Proof. + intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. + simpl. rewrite regset_same_assign. auto. + simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. +Qed. + +(** The following lemmas show that straight-line executions + (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) + +Lemma exec_straight_steps_1: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + plus step ge (State rs m) E0 (State rs' m'). +Proof. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_bblock_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_bblock_tail. eauto. + apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. + auto. + apply code_tail_next_int; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall c rs m c' rs' m', + exec_straight_blocks c rs m c' rs' m' -> + size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr ge b = Some (Internal fn) -> + code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. +Proof. + induction 1; intros. + exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int; auto. + apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). + auto. rewrite H0. rewrite H3. reflexivity. auto. + apply code_tail_next_int; auto. +Qed. + +End STRAIGHTLINE. + +(** * Properties of the Machblock call stack *) + +Section MATCH_STACK. + +Variable ge: MB.genv. + +Inductive match_stack: list MB.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f tf tc, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + transl_code_at_pc ge ra fb f c false tf tc -> + sp <> Vundef -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + auto. +Qed. + +Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. +Proof. + induction 1; simpl. + unfold Vnullptr; destruct Archi.ptr64; congruence. + inv H0. congruence. +Qed. + +Lemma lessdef_parent_sp: + forall s v, + match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. +Proof. + intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. +Qed. + +Lemma lessdef_parent_ra: + forall s v, + match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. +Proof. + intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. +Qed. + +End MATCH_STACK. diff --git a/kvx/lib/ForwardSimulationBlock.v b/kvx/lib/ForwardSimulationBlock.v new file mode 100644 index 00000000..f79814f2 --- /dev/null +++ b/kvx/lib/ForwardSimulationBlock.v @@ -0,0 +1,387 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +(*** + +Auxiliary lemmas on starN and forward_simulation +in order to prove the forward simulation of Mach -> Machblock. + +***) + +Require Import Relations. +Require Import Wellfounded. +Require Import Coqlib. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. + + +Local Open Scope nat_scope. + + +(** Auxiliary lemma on starN *) +Section starN_lemma. + +Variable L: semantics. + +Local Hint Resolve starN_refl starN_step Eapp_assoc: core. + +Lemma starN_split n s t s': + starN (step L) (globalenv L) n s t s' -> + forall m k, n=m+k -> + exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. +Proof. + induction 1; simpl. + + intros m k H; assert (X: m=0); try omega. + assert (X0: k=0); try omega. + subst; repeat (eapply ex_intro); intuition eauto. + + intros m; destruct m as [| m']; simpl. + - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. + - intros k H2. inversion H2. + exploit (IHstarN m' k); eauto. intro. + destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). + repeat (eapply ex_intro). + instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). + intuition eauto. subst. auto. +Qed. + +Lemma starN_tailstep n s t1 s': + starN (step L) (globalenv L) n s t1 s' -> + forall (t t2:trace) s'', + Step L s' t2 s'' -> t = t1 ** t2 -> starN (step L) (globalenv L) (S n) s t s''. +Proof. + induction 1; simpl. + + intros t t1 s0; autorewrite with trace_rewrite. + intros; subst; eapply starN_step; eauto. + autorewrite with trace_rewrite; auto. + + intros. eapply starN_step; eauto. + intros; subst; autorewrite with trace_rewrite; auto. +Qed. + +End starN_lemma. + + + +(** General scheme from a "match_states" relation *) + +Section ForwardSimuBlock_REL. + +Variable L1 L2: semantics. + + +(** Hypothèses de la preuve *) + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Variable match_states: state L1 -> state L2 -> Prop. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 s2 r, final_state L1 s1 r -> match_states s1 s2 -> final_state L2 s2 r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> match_states s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states s1' s2'. + + +(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) + +Local Hint Resolve starN_refl starN_step: core. + +Definition follows_in_block (head current: state L1): Prop := + dist_end_block head >= dist_end_block current + /\ starN (step L1) (globalenv L1) (minus (dist_end_block head) (dist_end_block current)) head E0 current. + +Lemma follows_in_block_step (head previous next: state L1): + forall t, follows_in_block head previous -> Step L1 previous t next -> (dist_end_block previous)<>0 -> follows_in_block head next. +Proof. + intros t [H1 H2] H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)). + - eapply starN_tailstep; eauto. + - omega. +Qed. + +Lemma follows_in_block_init (head current: state L1): + forall t, Step L1 head t current -> (dist_end_block head)<>0 -> follows_in_block head current. +Proof. + intros t H3 H4. + destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. + constructor 1. + + omega. + + cutrewrite (dist_end_block head - dist_end_block current = 1). + - eapply starN_tailstep; eauto. + - omega. +Qed. + + +Record memostate := { + real: state L1; + memorized: option (state L1); + memo_star: forall head, memorized = Some head -> follows_in_block head real; + memo_final: forall r, final_state L1 real r -> memorized = None +}. + +Definition head (s: memostate): state L1 := + match memorized s with + | None => real s + | Some s' => s' + end. + +Lemma head_followed (s: memostate): follows_in_block (head s) (real s). +Proof. + destruct s as [rs ms Hs]. simpl. + destruct ms as [ms|]; unfold head; simpl; auto. + constructor 1. + omega. + cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O). + + apply starN_refl; auto. + + omega. +Qed. + +Inductive is_well_memorized (s s': memostate): Prop := + | StartBloc: + dist_end_block (real s) <> O -> + memorized s = None -> + memorized s' = Some (real s) -> + is_well_memorized s s' + | MidBloc: + dist_end_block (real s) <> O -> + memorized s <> None -> + memorized s' = memorized s -> + is_well_memorized s s' + | ExitBloc: + dist_end_block (real s) = O -> + memorized s' = None -> + is_well_memorized s s'. + +Local Hint Resolve StartBloc MidBloc ExitBloc: core. + +Definition memoL1 := {| + state := memostate; + genvtype := genvtype L1; + step := fun ge s t s' => + step L1 ge (real s) t (real s') + /\ is_well_memorized s s' ; + initial_state := fun s => initial_state L1 (real s) /\ memorized s = None; + final_state := fun s r => final_state L1 (real s) r; + globalenv:= globalenv L1; + symbolenv:= symbolenv L1 +|}. + + +(** Preuve des 2 forward simulations: L1 -> memoL1 et memoL1 -> L2 *) + +Lemma discr_dist_end s: + {dist_end_block s = O} + {dist_end_block s <> O}. +Proof. + destruct (dist_end_block s); simpl; intuition. +Qed. + +Lemma memo_simulation_step: + forall s1 t s1', Step L1 s1 t s1' -> + forall s2, s1 = (real s2) -> exists s2', Step memoL1 s2 t s2' /\ s1' = (real s2'). +Proof. + intros s1 t s1' H1 [rs2 ms2 Hmoi] H2. simpl in H2; subst. + destruct (discr_dist_end rs2) as [H3 | H3]. + + refine (ex_intro _ {|real:=s1'; memorized:=None |} _); simpl. + intuition. + + destruct ms2 as [s|]. + - refine (ex_intro _ {|real:=s1'; memorized:=Some s |} _); simpl. + intuition. + - refine (ex_intro _ {|real:=s1'; memorized:=Some rs2 |} _); simpl. + intuition. + Unshelve. + * intros; discriminate. + * intros; auto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_step; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. + * intros head X; injection X; clear X; intros; subst. + eapply follows_in_block_init; eauto. + * intros r X; erewrite final_states_end_block in H3; intuition eauto. +Qed. + +Lemma forward_memo_simulation_1: forward_simulation L1 memoL1. +Proof. + apply forward_simulation_step with (match_states:=fun s1 s2 => s1 = (real s2)); auto. + + intros s1 H; eapply ex_intro with (x:={|real:=s1; memorized:=None |}); simpl. + intuition. + + intros; subst; auto. + + intros; exploit memo_simulation_step; eauto. + Unshelve. + * intros; discriminate. + * auto. +Qed. + +Lemma forward_memo_simulation_2: forward_simulation memoL1 L2. +Proof. + unfold memoL1; simpl. + apply forward_simulation_opt with (measure:=fun s => dist_end_block (real s)) (match_states:=fun s1 s2 => match_states (head s1) s2); simpl; auto. + + intros s1 [H0 H1]; destruct (match_initial_states (real s1) H0). + unfold head; rewrite H1. + intuition eauto. + + intros s1 s2 r X H0; unfold head in X. + erewrite memo_final in X; eauto. + + intros s1 t s1' [H1 H2] s2 H; subst. + destruct H2 as [ H0 H2 H3 | H0 H2 H3 | H0 H2]. + - (* StartBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H2 in H. rewrite H3. rewrite H4. intuition. + - (* MidBloc *) + constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. + unfold head in * |- *. rewrite H3. rewrite H4. intuition. + destruct (memorized s1); simpl; auto. tauto. + - (* EndBloc *) + constructor 1. + destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto. + * destruct (head_followed s1) as [H4 H3]. + cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega. + eapply starN_tailstep; eauto. + * unfold head; rewrite H2; simpl. intuition eauto. +Qed. + +Lemma forward_simulation_block_rel: forward_simulation L1 L2. +Proof. + eapply compose_forward_simulations. + eapply forward_memo_simulation_1. + apply forward_memo_simulation_2. +Qed. + + +End ForwardSimuBlock_REL. + + + +(* An instance of the previous scheme, when there is a translation from L1 states to L2 states + +Here, we do not require that the sequence of S2 states does exactly match the sequence of L1 states by trans_state. +This is because the exact matching is broken in Machblock on "goto" instruction (due to the find_label). + +However, the Machblock state after a goto remains "equivalent" to the trans_state of the Mach state in the sense of "equiv_on_next_step" below... + +*) + + +Section ForwardSimuBlock_TRANS. + +Variable L1 L2: semantics. + +Variable trans_state: state L1 -> state L2. + +Definition equiv_on_next_step (P Q: Prop) s2_a s2_b: Prop := + (P -> (forall t s', Step L2 s2_a t s' <-> Step L2 s2_b t s')) /\ (Q -> (forall r, (final_state L2 s2_a r) <-> (final_state L2 s2_b r))). + +Definition match_states s1 s2: Prop := + equiv_on_next_step (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 (trans_state s1). + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + unfold match_states, equiv_on_next_step. intuition. +Qed. + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 r, final_state L1 s1 r -> final_state L2 (trans_state s1) r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1', starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> exists s2', Step L2 (trans_state s1) t s2' /\ match_states s1' s2'. + +Lemma forward_simulation_block_trans: forward_simulation L1 L2. +Proof. + eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states); try tauto. + + (* final_states *) intros s1 s2 r H1 [H2 H3]. rewrite H3; eauto. + + (* simu_end_block *) + intros s1 t s1' s2 H1 [H2a H2b]. exploit simu_end_block; eauto. + intros (s2' & H3 & H4); econstructor 1; intuition eauto. + rewrite H2a; auto. + inversion_clear H1. eauto. +Qed. + +End ForwardSimuBlock_TRANS. + + +(* another version with a relation [trans_state_R] instead of a function [trans_state] *) +Section ForwardSimuBlock_TRANS_R. + +Variable L1 L2: semantics. + +Variable trans_state_R: state L1 -> state L2 -> Prop. + +Definition match_states_R s1 s2: Prop := + exists s2', trans_state_R s1 s2' /\ equiv_on_next_step _ (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 s2'. + +Lemma match_states_trans_state_R s1 s2: trans_state_R s1 s2 -> match_states_R s1 s2. +Proof. + unfold match_states, equiv_on_next_step. firstorder. +Qed. + +Variable dist_end_block: state L1 -> nat. + +Hypothesis simu_mid_block: + forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). + +Hypothesis public_preserved: + forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. + +Hypothesis match_initial_states: + forall s1, initial_state L1 s1 -> exists s2, match_states_R s1 s2 /\ initial_state L2 s2. + +Hypothesis match_final_states: + forall s1 s2 r, final_state L1 s1 r -> trans_state_R s1 s2 -> final_state L2 s2 r. + +Hypothesis final_states_end_block: + forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. + +Hypothesis simu_end_block: + forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> trans_state_R s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states_R s1' s2'. + +Lemma forward_simulation_block_trans_R: forward_simulation L1 L2. +Proof. + eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states_R); try tauto. + + (* final_states *) intros s1 s2 r H1 (s2' & H2 & H3 & H4). rewrite H4; eauto. + + (* simu_end_block *) + intros s1 t s1' s2 H1 (s2' & H2 & H2a & H2b). exploit simu_end_block; eauto. + intros (x & Hx & (y & H3 & H4 & H5)). repeat (econstructor; eauto). + rewrite H2a; eauto. + inversion_clear H1. eauto. +Qed. + +End ForwardSimuBlock_TRANS_R. + diff --git a/kvx/lib/Machblock.v b/kvx/lib/Machblock.v new file mode 100644 index 00000000..08e0eba2 --- /dev/null +++ b/kvx/lib/Machblock.v @@ -0,0 +1,380 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. + +(** basic instructions (ie no control-flow) *) +Inductive basic_inst: Type := + | MBgetstack: ptrofs -> typ -> mreg -> basic_inst + | MBsetstack: mreg -> ptrofs -> typ -> basic_inst + | MBgetparam: ptrofs -> typ -> mreg -> basic_inst + | MBop: operation -> list mreg -> mreg -> basic_inst + | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst + . + +Definition bblock_body := list basic_inst. + +(** control flow instructions *) +Inductive control_flow_inst: Type := + | MBcall: signature -> mreg + ident -> control_flow_inst + | MBtailcall: signature -> mreg + ident -> control_flow_inst + | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst + | MBgoto: label -> control_flow_inst + | MBcond: condition -> list mreg -> label -> control_flow_inst + | MBjumptable: mreg -> list label -> control_flow_inst + | MBreturn: control_flow_inst + . + +Record bblock := mk_bblock { + header: list label; + body: bblock_body; + exit: option control_flow_inst +}. + +Lemma bblock_eq: + forall b1 b2, + header b1 = header b2 -> + body b1 = body b2 -> + exit b1 = exit b2 -> + b1 = b2. +Proof. + intros. destruct b1. destruct b2. + simpl in *. subst. auto. +Qed. + +Definition length_opt {A} (o: option A) : nat := + match o with + | Some o => 1 + | None => 0 + end. + +Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). + +Lemma size_null b: + size b = 0%nat -> + header b = nil /\ body b = nil /\ exit b = None. +Proof. + destruct b as [h b e]. simpl. unfold size. simpl. + intros H. + assert (length h = 0%nat) as Hh; [ omega |]. + assert (length b = 0%nat) as Hb; [ omega |]. + assert (length_opt e = 0%nat) as He; [ omega|]. + repeat split. + destruct h; try (simpl in Hh; discriminate); auto. + destruct b; try (simpl in Hb; discriminate); auto. + destruct e; try (simpl in He; discriminate); auto. +Qed. + +Definition code := list bblock. + +Record function: Type := mkfunction + { fn_sig: signature; + fn_code: code; + fn_stacksize: Z; + fn_link_ofs: ptrofs; + fn_retaddr_ofs: ptrofs }. + +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef unit. + +Definition genv := Genv.t fundef unit. + +(*** sémantique ***) + +Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. +Proof. + apply List.in_dec. + apply Pos.eq_dec. +Qed. + +Definition is_label (lbl: label) (bb: bblock) : bool := + if in_dec lbl (header bb) then true else false. + +Lemma is_label_correct_true lbl bb: + List.In lbl (header bb) <-> is_label lbl bb = true. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + +Lemma is_label_correct_false lbl bb: + ~(List.In lbl (header bb)) <-> is_label lbl bb = false. +Proof. + unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. +Qed. + + +Local Open Scope nat_scope. + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl + end. + +Section RELSEM. + +Variable rao:function -> code -> ptrofs -> Prop. +Variable ge:genv. + +Definition find_function_ptr + (ge: genv) (ros: mreg + ident) (rs: regset) : option block := + match ros with + | inl r => + match rs r with + | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None + | _ => None + end + | inr symb => + Genv.find_symbol ge symb + end. + +(** Machblock execution states. *) + +Inductive stackframe: Type := + | Stackframe: + forall (f: block) (**r pointer to calling function *) + (sp: val) (**r stack pointer in calling function *) + (retaddr: val) (**r Asm return address in calling function *) + (c: code), (**r program point in calling function *) + stackframe. + +Inductive state: Type := + | State: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to current function *) + (sp: val) (**r stack pointer *) + (c: code) (**r current program point *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Callstate: + forall (stack: list stackframe) (**r call stack *) + (f: block) (**r pointer to function to call *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state + | Returnstate: + forall (stack: list stackframe) (**r call stack *) + (rs: regset) (**r register state *) + (m: mem), (**r memory state *) + state. + +Definition parent_sp (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => sp + end. + +Definition parent_ra (s: list stackframe) : val := + match s with + | nil => Vnullptr + | Stackframe f sp ra c :: s' => ra + end. + +Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := + | exec_MBgetstack: + forall ofs ty dst v, + load_stack m sp ty ofs = Some v -> + basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m + | exec_MBsetstack: + forall src ofs ty m' rs', + store_stack m sp ty ofs (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_setstack ty) rs -> + basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' + | exec_MBgetparam: + forall ofs ty dst v rs' f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (parent_sp s) ty ofs = Some v -> + rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> + basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m + | exec_MBop: + forall op args v rs' res, + eval_operation ge sp op rs##args m = Some v -> + rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> + basic_step s fb sp rs m (MBop op args res) rs' m + | exec_MBload: + forall addr args a v rs' trap chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> + basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m + | exec_MBload_notrap1: + forall addr args rs' chunk dst, + eval_addressing ge sp addr rs##args = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m + | exec_MBload_notrap2: + forall addr args a rs' chunk dst, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = None -> + rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> + basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m + | exec_MBstore: + forall chunk addr args src m' a rs', + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + rs' = undef_regs (destroyed_by_store chunk addr) rs -> + basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' + . + + +Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := + | exec_nil_body: + forall rs m, + body_step s f sp nil rs m rs m + | exec_cons_body: + forall rs m bi p rs' m' rs'' m'', + basic_step s f sp rs m bi rs' m' -> + body_step s f sp p rs' m' rs'' m'' -> + body_step s f sp (bi::p) rs m rs'' m'' + . + +Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := + | exec_MBcall: + forall s fb sp sig ros c b rs m f f' ra, + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + rao f c ra -> + cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) + E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) + f' rs m) + | exec_MBtailcall: + forall s fb stk soff sig ros c rs m f f' m', + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) + E0 (Callstate s f' rs m') + | exec_MBbuiltin: + forall s f sp rs m ef args res b c vargs t vres rs' m', + eval_builtin_args ge rs sp m args vargs -> + external_call ef ge vargs m t vres m' -> + rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> + cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) + t (State s f sp c rs' m') + | exec_MBgoto: + forall s fb f sp lbl c rs m c', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + cfi_step (MBgoto lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs m) + | exec_MBcond_true: + forall s fb f sp cond args lbl c rs m c' rs', + eval_condition cond rs##args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBcond_false: + forall s f sp cond args lbl b c rs m rs', + eval_condition cond rs##args m = Some false -> + rs' = undef_regs (destroyed_by_cond cond) rs -> + cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) + E0 (State s f sp c rs' m) + | exec_MBjumptable: + forall s fb f sp arg tbl c rs m n lbl c' rs', + rs arg = Vint n -> + list_nth_z tbl (Int.unsigned n) = Some lbl -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + rs' = undef_regs destroyed_by_jumptable rs -> + cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) + E0 (State s fb sp c' rs' m) + | exec_MBreturn: + forall s fb stk soff c rs m f m', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) + E0 (Returnstate s rs m') + . + +Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := + | exec_Some_exit: + forall ctl s t s', + cfi_step ctl s t s' -> + exit_step (Some ctl) s t s' + | exec_None_exit: + forall stk f sp b lb rs m, + exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) + . + +Inductive step: state -> trace -> state -> Prop := + | exec_bblock: + forall sf f sp bb c rs m rs' m' t s', + body_step sf f sp (body bb) rs m rs' m' -> + exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> + step (State sf f sp (bb::c) rs m) t s' + | exec_function_internal: + forall s fb rs m f m1 m2 m3 stk rs', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + let sp := Vptr stk Ptrofs.zero in + store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + rs' = undef_regs destroyed_at_function_entry rs -> + step (Callstate s fb rs m) + E0 (State s fb sp f.(fn_code) rs' m3) + | exec_function_external: + forall s fb rs m t rs' ef args res m', + Genv.find_funct_ptr ge fb = Some (External ef) -> + extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> + external_call ef ge args m t res m' -> + rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> + step (Callstate s fb rs m) + t (Returnstate s rs' m') + | exec_return: + forall s f sp ra c rs m, + step (Returnstate (Stackframe f sp ra c :: s) rs m) + E0 (State s f sp c rs m) + . + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall fb m0, + let ge := Genv.globalenv p in + Genv.init_mem p = Some m0 -> + Genv.find_symbol ge p.(prog_main) = Some fb -> + initial_state p (Callstate nil fb (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r retcode, + loc_result signature_main = One r -> + rs r = Vint retcode -> + final_state (Returnstate nil rs m) retcode. + +Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := + Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/kvx/lib/Machblockgen.v b/kvx/lib/Machblockgen.v new file mode 100644 index 00000000..287e4f7b --- /dev/null +++ b/kvx/lib/Machblockgen.v @@ -0,0 +1,216 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. + +Inductive Machblock_inst: Type := +| MB_label (lbl: label) +| MB_basic (bi: basic_inst) +| MB_cfi (cfi: control_flow_inst). + +Definition trans_inst (i:Mach.instruction) : Machblock_inst := + match i with + | Mcall sig ros => MB_cfi (MBcall sig ros) + | Mtailcall sig ros => MB_cfi (MBtailcall sig ros) + | Mbuiltin ef args res => MB_cfi (MBbuiltin ef args res) + | Mgoto lbl => MB_cfi (MBgoto lbl) + | Mcond cond args lbl => MB_cfi (MBcond cond args lbl) + | Mjumptable arg tbl => MB_cfi (MBjumptable arg tbl) + | Mreturn => MB_cfi (MBreturn) + | Mgetstack ofs ty dst => MB_basic (MBgetstack ofs ty dst) + | Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty) + | Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst) + | Mop op args res => MB_basic (MBop op args res) + | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst) + | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) + | Mlabel l => MB_label l + end. + +Definition empty_bblock:={| header := nil; body := nil; exit := None |}. +Extraction Inline empty_bblock. + +Definition add_label l bb:={| header := l::(header bb); body := (body bb); exit := (exit bb) |}. +Extraction Inline add_label. + +Definition add_basic bi bb :={| header := nil; body := bi::(body bb); exit := (exit bb) |}. +Extraction Inline add_basic. + +Definition cfi_bblock cfi:={| header := nil; body := nil; exit := Some cfi |}. +Extraction Inline cfi_bblock. + +Definition add_to_new_bblock (i:Machblock_inst) : bblock := + match i with + | MB_label l => add_label l empty_bblock + | MB_basic i => add_basic i empty_bblock + | MB_cfi i => cfi_bblock i + end. + +(** Adding an instruction to the beginning of a bblock list + * Either adding the instruction to the head of the list, + * or create a new bblock with the instruction *) +Definition add_to_code (i:Machblock_inst) (bl:code) : code := + match bl with + | bh::bl0 => match i with + | MB_label l => add_label l bh::bl0 + | MB_cfi i0 => cfi_bblock i0::bl + | MB_basic i0 => match header bh with + |_::_ => add_basic i0 empty_bblock::bl + | nil => add_basic i0 bh::bl0 + end + end + | _ => add_to_new_bblock i::nil + end. + +Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := + match c with + | nil => bl + | i::c0 => + trans_code_rev c0 (add_to_code (trans_inst i) bl) + end. + +Function trans_code (c: Mach.code) : code := + trans_code_rev (List.rev_append c nil) nil. + +Definition transf_function (f: Mach.function) : function := + {| fn_sig:=Mach.fn_sig f; + fn_code:=trans_code (Mach.fn_code f); + fn_stacksize := Mach.fn_stacksize f; + fn_link_ofs := Mach.fn_link_ofs f; + fn_retaddr_ofs := Mach.fn_retaddr_ofs f + |}. + +Definition transf_fundef (f: Mach.fundef) : fundef := + transf_fundef transf_function f. + +Definition transf_program (src: Mach.program) : program := + transform_program transf_fundef src. + + +(** Abstracting trans_code *) + +Inductive is_end_block: Machblock_inst -> code -> Prop := + | End_empty mbi: is_end_block mbi nil + | End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl) + | End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl. + +Local Hint Resolve End_empty End_basic End_cfi: core. + +Inductive is_trans_code: Mach.code -> code -> Prop := + | Tr_nil: is_trans_code nil nil + | Tr_end_block i c bl: + is_trans_code c bl -> + is_end_block (trans_inst i) bl -> + is_trans_code (i::c) (add_to_new_bblock (trans_inst i)::bl) + | Tr_add_label i l bh c bl: + is_trans_code c (bh::bl) -> + i = Mlabel l -> + is_trans_code (i::c) (add_label l bh::bl) + | Tr_add_basic i bi bh c bl: + is_trans_code c (bh::bl) -> + trans_inst i = MB_basic bi -> + header bh = nil -> + is_trans_code (i::c) (add_basic bi bh::bl). + +Local Hint Resolve Tr_nil Tr_end_block: core. + +Lemma add_to_code_is_trans_code i c bl: + is_trans_code c bl -> + is_trans_code (i::c) (add_to_code (trans_inst i) bl). +Proof. + destruct bl as [|bh0 bl]; simpl. + - intro H. inversion H. subst. eauto. + - remember (trans_inst i) as ti. + destruct ti as [l|bi|cfi]. + + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. + + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. + * eapply Tr_add_basic; eauto. + * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. + rewrite Heqti; eapply Tr_end_block; eauto. + rewrite <- Heqti. eapply End_basic. congruence. + + intros. + cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. + rewrite Heqti. eapply Tr_end_block; eauto. + rewrite <- Heqti. eapply End_cfi. congruence. +Qed. + +Local Hint Resolve add_to_code_is_trans_code: core. + +Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, + is_trans_code c2 mbi -> + is_trans_code (rev_append c1 c2) (trans_code_rev c1 mbi). +Proof. + induction c1 as [| i c1]; simpl; auto. +Qed. + +Lemma trans_code_is_trans_code c: is_trans_code c (trans_code c). +Proof. + unfold trans_code. + rewrite <- rev_alt. + rewrite <- (rev_involutive c) at 1. + rewrite rev_alt at 1. + apply trans_code_is_trans_code_rev; auto. +Qed. + +Lemma add_to_code_is_trans_code_inv i c bl: + is_trans_code (i::c) bl -> exists bl0, is_trans_code c bl0 /\ bl = add_to_code (trans_inst i) bl0. +Proof. + intro H; inversion H as [|H0 H1 bl0| | H0 bi bh H1 bl0]; clear H; subst; (repeat econstructor); eauto. + + (* case Tr_end_block *) inversion H3; subst; simpl; auto. + * destruct (header bh); congruence. + * destruct bl0; simpl; congruence. + + (* case Tr_add_basic *) rewrite H3. simpl. destruct (header bh); congruence. +Qed. + +Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, + is_trans_code (rev_append c1 c2) mbi -> + exists mbi0, is_trans_code c2 mbi0 /\ mbi=trans_code_rev c1 mbi0. +Proof. + induction c1 as [| i c1]; simpl; eauto. + intros; exploit IHc1; eauto. + intros (mbi0 & H1 & H2); subst. + exploit add_to_code_is_trans_code_inv; eauto. + intros. destruct H0 as [mbi1 [H2 H3]]. + exists mbi1. split; congruence. +Qed. + +Local Hint Resolve trans_code_is_trans_code: core. + +Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). +Proof. + constructor; intros; subst; auto. + unfold trans_code. + exploit (trans_code_is_trans_code_rev_inv (rev_append c nil) nil bl); eauto. + * rewrite <- rev_alt. + rewrite <- rev_alt. + rewrite (rev_involutive c). + apply H. + * intros. + destruct H0 as [mbi [H0 H1]]. + inversion H0. subst. reflexivity. +Qed. diff --git a/kvx/lib/Machblockgenproof.v b/kvx/lib/Machblockgenproof.v new file mode 100644 index 00000000..dfb97bfe --- /dev/null +++ b/kvx/lib/Machblockgenproof.v @@ -0,0 +1,824 @@ +(* *************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Sylvain Boulmé Grenoble-INP, VERIMAG *) +(* David Monniaux CNRS, VERIMAG *) +(* Cyril Six Kalray *) +(* *) +(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) +(* This file is distributed under the terms of the INRIA *) +(* Non-Commercial License Agreement. *) +(* *) +(* *************************************************************) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Memory. +Require Import Globalenvs. +Require Import Events. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Stacklayout. +Require Import Mach. +Require Import Linking. +Require Import Machblock. +Require Import Machblockgen. +Require Import ForwardSimulationBlock. + +Ltac subst_is_trans_code H := + rewrite is_trans_code_inv in H; + rewrite <- H in * |- *; + rewrite <- is_trans_code_inv in H. + +Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := + rao (transf_function f) (trans_code c). + +Definition match_prog (p: Mach.program) (tp: Machblock.program) := + match_program (fun _ f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: forall p tp, transf_program p = tp -> match_prog p tp. +Proof. + intros. rewrite <- H. eapply match_transform_program; eauto. +Qed. + +Definition trans_stackframe (msf: Mach.stackframe) : stackframe := + match msf with + | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) + end. + +Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := + match mst with + | nil => nil + | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) + end. + +Definition trans_state (ms: Mach.state): state := + match ms with + | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m + | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m + | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m + end. + +Section PRESERVATION. + +Local Open Scope nat_scope. + +Variable prog: Mach.program. +Variable tprog: Machblock.program. +Hypothesis TRANSF: match_prog prog tprog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + + +Variable rao: function -> code -> ptrofs -> Prop. + +Definition match_states: Mach.state -> state -> Prop + := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. + +Lemma match_states_trans_state s1: match_states s1 (trans_state s1). +Proof. + apply match_states_trans_state. +Qed. + +Local Hint Resolve match_states_trans_state: core. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + +Lemma init_mem_preserved: + forall m, + Genv.init_mem prog = Some m -> + Genv.init_mem tprog = Some m. +Proof (Genv.init_mem_transf TRANSF). + +Lemma prog_main_preserved: + prog_main tprog = prog_main prog. +Proof (match_program_main TRANSF). + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. +Proof. + intros. + exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. + destruct H0 as (cunit & tf & A & B & C). + eapply ex_intro. intuition; eauto. subst. eapply A. +Qed. + +Lemma find_function_ptr_same: + forall s rs, + Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. +Proof. + intros. unfold Mach.find_function_ptr. unfold find_function_ptr. + destruct s; auto. + rewrite symbols_preserved; auto. +Qed. + +Lemma find_funct_ptr_same: + forall f f0, + Genv.find_funct_ptr ge f = Some (Internal f0) -> + Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma find_funct_ptr_same_external: + forall f f0, + Genv.find_funct_ptr ge f = Some (External f0) -> + Genv.find_funct_ptr tge f = Some (External f0). +Proof. + intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. +Qed. + +Lemma parent_sp_preserved: + forall s, + Mach.parent_sp s = parent_sp (trans_stack s). +Proof. + unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma parent_ra_preserved: + forall s, + Mach.parent_ra s = parent_ra (trans_stack s). +Proof. + unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. + unfold trans_stackframe. destruct s; simpl; auto. +Qed. + +Lemma external_call_preserved: + forall ef args m t res m', + external_call ef ge args m t res m' -> + external_call ef tge args m t res m'. +Proof. + intros. eapply external_call_symbols_preserved; eauto. + apply senv_preserved. +Qed. + +Lemma Mach_find_label_split l i c c': + Mach.find_label l (i :: c) = Some c' -> + (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). +Proof. + intros H. + destruct i; try (constructor 2; split; auto; discriminate ). + destruct (peq l0 l) as [P|P]. + - constructor. subst l0; split; auto. + revert H. unfold Mach.find_label. simpl. rewrite peq_true. + intros H; injection H; auto. + - constructor 2. split. + + intro F. injection F. intros. contradict P; auto. + + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. +Qed. + +Lemma find_label_is_end_block_not_label i l c bl: + is_end_block (trans_inst i) bl -> + is_trans_code c bl -> + i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. +Proof. + intros H H0 H1. + unfold find_label. + remember (is_label l _) as b. + cutrewrite (b = false); auto. + subst; unfold is_label. + destruct i; simpl in * |- *; try (destruct (in_dec l nil); intuition). + inversion H. + destruct (in_dec l (l0::nil)) as [H6|H6]; auto. + simpl in H6; intuition try congruence. +Qed. + +Lemma find_label_at_begin l bh bl: + In l (header bh) + -> find_label l (bh :: bl) = Some (bh::bl). +Proof. + unfold find_label; rewrite is_label_correct_true; intro H; rewrite H; simpl; auto. +Qed. + +Lemma find_label_add_label_diff l bh bl: + ~(In l (header bh)) -> + find_label l (bh::bl) = find_label l bl. +Proof. + unfold find_label; rewrite is_label_correct_false; intro H; rewrite H; simpl; auto. +Qed. + +Definition concat (h: list label) (c: code): code := + match c with + | nil => {| header := h; body := nil; exit := None |}::nil + | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' + end. + +Lemma find_label_transcode_preserved: + forall l c c', + Mach.find_label l c = Some c' -> + exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). +Proof. + intros l c. remember (trans_code _) as bl. + rewrite <- is_trans_code_inv in * |-. + induction Heqbl. + + (* Tr_nil *) + intros; exists (l::nil); simpl in * |- *; intuition. + discriminate. + + (* Tr_end_block *) + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. rewrite find_label_at_begin; simpl; auto. + inversion H as [mbi H1 H2| | ]. + subst. + inversion Heqbl. + subst. + exists (l :: nil); simpl; eauto. + - exploit IHHeqbl; eauto. + destruct 1 as (h & H3 & H4). + exists h. + split; auto. + erewrite find_label_is_end_block_not_label;eauto. + + (* Tr_add_label *) + intros. + exploit Mach_find_label_split; eauto. + clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. + - subst. + inversion H0 as [H1]. + clear H0. + erewrite find_label_at_begin; simpl; eauto. + subst_is_trans_code Heqbl. + exists (l :: nil); simpl; eauto. + - subst; assert (H: l0 <> l); try congruence; clear H0. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. + intros (h & H3 & H4). + simpl; unfold is_label, add_label; simpl. + destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. + * destruct H5; try congruence. + exists (l0::h); simpl; intuition. + rewrite find_label_at_begin in H4; auto. + apply f_equal. inversion H4 as [H5]. clear H4. + destruct (trans_code c'); simpl in * |- *; + inversion H5; subst; simpl; auto. + * exists h. intuition. + erewrite <- find_label_add_label_diff; eauto. + + (* Tr_add_basic *) + intros. + exploit Mach_find_label_split; eauto. + destruct 1 as [(H2&H3)|(H2&H3)]. + rewrite H2 in H. unfold trans_inst in H. congruence. + exploit IHHeqbl; eauto. + clear IHHeqbl Heqbl. + intros (h & H4 & H5). + rewrite find_label_add_label_diff; auto. + rewrite find_label_add_label_diff in H5; eauto. + rewrite H0; auto. +Qed. + +Lemma find_label_preserved: + forall l f c, + Mach.find_label l (Mach.fn_code f) = Some c -> + exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). +Proof. + intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. + apply find_label_transcode_preserved; auto. +Qed. + +Lemma mem_free_preserved: + forall m stk f, + Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). +Proof. + intros. auto. +Qed. + +Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated + parent_sp_preserved: core. + + +Definition dist_end_block_code (c: Mach.code) := + match trans_code c with + | nil => 0 + | bh::_ => (size bh-1)%nat + end. + +Definition dist_end_block (s: Mach.state): nat := + match s with + | Mach.State _ _ _ c _ _ => dist_end_block_code c + | _ => 0 + end. + +Local Hint Resolve exec_nil_body exec_cons_body: core. +Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core. + +Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. +Proof. + unfold add_label, size; simpl; omega. +Qed. + +Lemma size_add_basic bi bh: header bh = nil -> size (add_basic bi bh) = size bh + 1. +Proof. + intro H. unfold add_basic, size; rewrite H; simpl. omega. +Qed. + + +Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. +Proof. + destruct i; auto. +Qed. + + +Lemma dist_end_block_code_simu_mid_block i c: + dist_end_block_code (i::c) <> 0 -> + (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). +Proof. + unfold dist_end_block_code. + remember (trans_code (i::c)) as bl. + rewrite <- is_trans_code_inv in Heqbl. + inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; + subst_is_trans_code H. + omega. + - rewrite size_add_basic; auto. + subst_is_trans_code H. + omega. +Qed. + +Local Hint Resolve dist_end_block_code_simu_mid_block: core. + + +Lemma size_nonzero c b bl: + is_trans_code c (b :: bl) -> size b <> 0. +Proof. + intros H; inversion H; subst. + - rewrite size_add_to_newblock; omega. + - rewrite size_add_label; omega. + - rewrite size_add_basic; auto; omega. +Qed. + +Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := + | header_empty : is_header nil nil nil + | header_not_label i c: (forall l, i <> Mlabel l) -> is_header nil (i::c) (i::c) + | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 + . + +Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := + | body_empty : is_body nil nil nil + | body_not_bi i c: (forall bi, (trans_inst i) <> (MB_basic bi)) -> is_body nil (i::c) (i::c) + | body_is_bi i lbi c0 c1 bi: (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 + . + +Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := + | exit_empty: is_exit None nil nil + | exit_not_cfi i c: (forall cfi, (trans_inst i) <> MB_cfi cfi) -> is_exit None (i::c) (i::c) + | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c + . + +Lemma Mlabel_is_not_basic i: + forall bi, trans_inst i = MB_basic bi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma Mlabel_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall l, i <> Mlabel l. +Proof. +intros. +unfold trans_inst in H. +destruct i; congruence. +Qed. + +Lemma MBbasic_is_not_cfi i: + forall cfi, trans_inst i = MB_cfi cfi -> forall bi, trans_inst i <> MB_basic bi. +Proof. +intros. +unfold trans_inst in H. +unfold trans_inst. +destruct i; congruence. +Qed. + + +Local Hint Resolve Mlabel_is_not_cfi: core. +Local Hint Resolve MBbasic_is_not_cfi: core. + +Lemma add_to_new_block_is_label i: + header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. +Proof. + intros. + unfold add_to_new_bblock in H. + destruct (trans_inst i) eqn : H1. + + exists lbl. + unfold trans_inst in H1. + destruct i; congruence. + + unfold add_basic in H; simpl in H; congruence. + + unfold cfi_bblock in H; simpl in H; congruence. +Qed. + +Local Hint Resolve Mlabel_is_not_basic: core. + +Lemma trans_code_decompose c: forall b bl, + is_trans_code c (b::bl) -> + exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. +Proof. + induction c as [|i c]. + { (* nil => absurd *) intros b bl H; inversion H. } + intros b bl H; remember (trans_inst i) as ti. + destruct ti as [lbl|bi|cfi]; + inversion H as [|d0 d1 d2 H0 H1| |]; subst; + try (rewrite <- Heqti in * |- *); simpl in * |- *; + try congruence. + + (* label at end block *) + inversion H1; subst. inversion H0; subst. + assert (X:i=Mlabel lbl). { destruct i; simpl in Heqti; congruence. } + subst. repeat econstructor; eauto. + + (* label at mid block *) + exploit IHc; eauto. + intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). + repeat econstructor; eauto. + + (* basic at end block *) + inversion H1; subst. + lapply (Mlabel_is_not_basic i bi); auto. + intro H2. + - inversion H0; subst. + assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } + repeat econstructor; congruence. + - exists (i::c), c, c. + repeat econstructor; eauto; inversion H0; subst; repeat econstructor; simpl; try congruence. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + * exploit H3; eauto. + * exploit (add_to_new_block_is_label i0); eauto. + intros (l & H8); subst; simpl; congruence. + + (* basic at mid block *) + inversion H1; subst. + exploit IHc; eauto. + intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). + exists (i::c0), c1, c2. + repeat econstructor; eauto. + rewrite H2 in H3. + inversion H3; econstructor; eauto. + + (* cfi at end block *) + inversion H1; subst; + repeat econstructor; eauto. +Qed. + + +Lemma step_simu_header st f sp rs m s c h c' t: + is_header h c c' -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> + s = Mach.State st f sp c' rs m /\ t = E0. +Proof. + induction 1; simpl; intros hs; try (inversion hs; tauto). + inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. +Qed. + + + +Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): + trans_inst i = MB_basic bi -> + Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. +Proof. + destruct i; simpl in * |-; + (discriminate + || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). + - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. + destruct H3 as (tf & A & B). subst. eapply A. + all: simpl; rewrite <- parent_sp_preserved; auto. + - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. + - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; + unfold Genv.symbol_address; rewrite symbols_preserved; auto. +Qed. + + +Lemma star_step_simu_body_step s f sp c bdy c': + is_body bdy c c' -> forall rs m t s', + starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> + exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. +Proof. + induction 1; simpl. + + intros. inversion H. exists rs. exists m. auto. + + intros. inversion H0. exists rs. exists m. auto. + + intros. inversion H1; subst. + exploit (step_simu_basic_step ); eauto. + destruct 1 as [ rs1 [ m1 Hs]]. + destruct Hs as [Hs1 [Hs2 Hs3]]. + destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. + destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. + exists rs2, m2. + rewrite Hs2, Hb2; eauto. + Qed. + +Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core. +Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core. + + +Lemma match_states_concat_trans_code st f sp c rs m h: + match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). +Proof. + intros; constructor 1; simpl. + + intros (t0 & s1' & H0) t s'. + remember (trans_code _) as bl. + destruct bl as [|bh bl]. + { rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; inversion H0; congruence. } + clear H0. + simpl; constructor 1; + intros X; inversion X as [d1 d2 d3 d4 d5 d6 d7 rs' m' d10 d11 X1 X2| | | ]; subst; simpl in * |- *; + eapply exec_bblock; eauto; simpl; + inversion X2 as [cfi d1 d2 d3 H1|]; subst; eauto; + inversion H1; subst; eauto. + + intros H r; constructor 1; intro X; inversion X. +Qed. + +Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: + trans_inst i = MB_cfi cfi -> + is_trans_code c blc -> + Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> + exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s' s2. +Proof. + destruct i; simpl in * |-; + (intro H; intro Htc;apply is_trans_code_inv in Htc;rewrite Htc;inversion_clear H;intro X; inversion_clear X). + * eapply ex_intro. + intuition auto. + eapply exec_MBcall;eauto. + rewrite <-H; exploit (find_function_ptr_same); eauto. + * eapply ex_intro. + intuition auto. + eapply exec_MBtailcall;eauto. + - rewrite <-H; exploit (find_function_ptr_same); eauto. + - simpl; rewrite <- parent_sp_preserved; auto. + - simpl; rewrite <- parent_ra_preserved; auto. + * eapply ex_intro. + intuition auto. + eapply exec_MBbuiltin ;eauto. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * exploit find_label_transcode_preserved; eauto. + intros (x & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBcond_false; eauto. + * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). + eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. + * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. + eapply exec_MBreturn; eauto. + rewrite parent_sp_preserved in H0; subst; auto. + rewrite parent_ra_preserved in H1; subst; auto. +Qed. + +Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: + is_exit e c c' -> is_trans_code c' blc -> + starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> + exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. +Proof. + destruct 1. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* None *) + intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). + split; eauto. + apply is_trans_code_inv in H0. + rewrite H0. + apply match_states_trans_state. + - (* Some *) + intros H0 H1. + inversion H1; subst. + exploit (step_simu_cfi_step); eauto. + intros [s2 [Hcfi1 Hcfi3]]. + inversion H4. subst; simpl. + autorewrite with trace_rewrite. + exists s2. + split;eauto. +Qed. + +Lemma simu_end_block: + forall s1 t s1', + starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> + exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. +Proof. + destruct s1; simpl. + + (* State *) + remember (trans_code _) as tc. + rewrite <- is_trans_code_inv in Heqtc. + intros t s1 H. + destruct tc as [|b bl]. + { (* nil => absurd *) + inversion Heqtc. subst. + unfold dist_end_block_code; simpl. + inversion_clear H; + inversion_clear H0. + } + assert (X: Datatypes.S (dist_end_block_code c) = (size b)). + { + unfold dist_end_block_code. + subst_is_trans_code Heqtc. + lapply (size_nonzero c b bl); auto. + omega. + } + rewrite X in H; unfold size in H. + (* decomposition of starN in 3 parts: header + body + exit *) + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as (t3&t4&s1'&H0&H3&H4). + subst t; clear X H. + destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as (t1&t2&s1''&H&H1&H2). + subst t3; clear H0. + exploit trans_code_decompose; eauto. clear Heqtc. + intros (c0&c1&c2&Hc0&Hc1&Hc2&Heqtc). + (* header steps *) + exploit step_simu_header; eauto. + clear H; intros [X1 X2]; subst. + (* body steps *) + exploit (star_step_simu_body_step); eauto. + clear H1; intros (rs'&m'&H0&H1&H2). subst. + autorewrite with trace_rewrite. + (* exit step *) + exploit step_simu_exit_step; eauto. + clear H3; intros (s2' & H3 & H4). + eapply ex_intro; intuition eauto. + eapply exec_bblock; eauto. + + (* Callstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + - (* function_internal*) + cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. + eapply exec_function_internal; eauto. + rewrite <- parent_sp_preserved; eauto. + rewrite <- parent_ra_preserved; eauto. + - (* function_external *) + autorewrite with trace_rewrite. + eapply exec_function_external; eauto. + apply find_funct_ptr_same_external; auto. + rewrite <- parent_sp_preserved; eauto. + + (* Returnstate *) + intros t s1' H; inversion_clear H. + eapply ex_intro; constructor 1; eauto. + inversion H1; subst; clear H1. + inversion_clear H0; simpl. + eapply exec_return. +Qed. + + +Lemma cfi_dist_end_block i c: +(exists cfi, trans_inst i = MB_cfi cfi) -> +dist_end_block_code (i :: c) = 0. +Proof. + unfold dist_end_block_code. + intro H. destruct H as [cfi H]. + destruct i;simpl in H;try(congruence); ( + remember (trans_code _) as bl; + rewrite <- is_trans_code_inv in Heqbl; + inversion Heqbl; subst; simpl in * |- *; try (congruence)). +Qed. + +Theorem transf_program_correct: + forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). +Proof. + apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). +(* simu_mid_block *) + - intros s1 t s1' H1 H2. + destruct H1; simpl in * |- *; omega || (intuition auto); + destruct H2; eapply cfi_dist_end_block; simpl; eauto. +(* public_preserved *) + - apply senv_preserved. +(* match_initial_states *) + - intros. simpl. + eapply ex_intro; constructor 1. + eapply match_states_trans_state. + destruct H. split. + apply init_mem_preserved; auto. + rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. +(* match_final_states *) + - intros. simpl. destruct H. split with (r := r); auto. +(* final_states_end_block *) + - intros. simpl in H0. + inversion H0. + inversion H; simpl; auto. + all: try (subst; discriminate). + apply cfi_dist_end_block; exists MBreturn; eauto. +(* simu_end_block *) + - apply simu_end_block. +Qed. + +End PRESERVATION. + +(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) + + + +Lemma is_trans_code_monotonic i c b l: + is_trans_code c (b::l) -> + exists l' b', is_trans_code (i::c) (l' ++ (b'::l)). +Proof. + intro H; destruct c as [|i' c]. { inversion H. } + remember (trans_inst i) as ti. + destruct ti as [lbl|bi|cfi]. + - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; simpl in * |- *; try congruence ). + exists nil; simpl; eexists. eapply Tr_add_label; eauto. + - (*i=basic*) + destruct i'. + 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. + cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. + rewrite Heqti. + eapply Tr_end_block; eauto. + rewrite <-Heqti. + eapply End_basic. inversion H; try(simpl; congruence). + simpl in H5; congruence. } + all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). + - (*i=cfi*) + destruct i; try(simpl in Heqti; congruence). + all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; + cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; + rewrite Heqti; + eapply Tr_end_block; eauto; + rewrite <-Heqti; + eapply End_cfi; congruence. +Qed. + +Lemma trans_code_monotonic i c b l: + (b::l) = trans_code c -> + exists l' b', trans_code (i::c) = (l' ++ (b'::l)). +Proof. + intro H; rewrite <- is_trans_code_inv in H. + destruct (is_trans_code_monotonic i c b l H) as (l' & b' & H0). + subst_is_trans_code H0. + eauto. +Qed. + +(* FIXME: these two lemma should go into [Coqlib.v] *) +Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). +Proof. + induction l1; simpl; auto with coqlib. +Qed. +Hint Resolve is_tail_app: coqlib. + +Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. +Proof. + induction l1; simpl; auto with coqlib. + intros l2 l3 H; inversion H; eauto with coqlib. +Qed. +Hint Resolve is_tail_app_inv: coqlib. + + +Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> + exists b, is_tail (b :: trans_code c) (trans_code c2). +Proof. + intros H; induction 1. + - intros; subst. + remember (trans_code (Mcall _ _::c)) as tc2. + rewrite <- is_trans_code_inv in Heqtc2. + inversion Heqtc2; simpl in * |- *; subst; try congruence. + subst_is_trans_code H1. + eapply ex_intro; eauto with coqlib. + - intros; exploit IHis_tail; eauto. clear IHis_tail. + intros (b & Hb). inversion Hb; clear Hb. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + exists b'; simpl; eauto with coqlib. + * exploit (trans_code_monotonic i c2); eauto. + intros (l' & b' & Hl'); rewrite Hl'. + simpl; eapply ex_intro. + eapply is_tail_trans; eauto with coqlib. +Qed. + +Section Mach_Return_Address. + +Variable return_address_offset: function -> code -> ptrofs -> Prop. + +Hypothesis ra_exists: forall (b: bblock) (f: function) (c : list bblock), + is_tail (b :: c) (fn_code f) -> exists ra : ptrofs, return_address_offset f c ra. + +Definition Mach_return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := + return_address_offset (transf_function f) (trans_code c) ofs. + +Lemma Mach_return_address_exists: + forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> + exists ra, Mach_return_address_offset f c ra. +Proof. + intros. + exploit Mach_Machblock_tail; eauto. + destruct 1. + eapply ra_exists; eauto. +Qed. + +End Mach_Return_Address. diff --git a/kvx/unittest/Makefile b/kvx/unittest/Makefile new file mode 100644 index 00000000..fcbede2d --- /dev/null +++ b/kvx/unittest/Makefile @@ -0,0 +1,13 @@ +# Needs to be called from CompCert root directory +# $ make -f kvx/unittest/Makefile postpass_test + +include Makefile.extr + +TEST_CMX=kvx/unittest/postpass_test.cmx + +UNITTEST_OBJS:=$(shell $(MODORDER) $(TEST_CMX)) + +postpass_test: $(UNITTEST_OBJS) + @echo "Linking $@ $(UNITTEST_OBJS)" + @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ + diff --git a/kvx/unittest/postpass_test.ml b/kvx/unittest/postpass_test.ml new file mode 100644 index 00000000..434bfaf7 --- /dev/null +++ b/kvx/unittest/postpass_test.ml @@ -0,0 +1,12 @@ +open Printf +open Asmblock +open Integers +open PostpassSchedulingOracle +open BinNums + +let test_schedule_sd = + let sd_inst = PStore (PStoreRRO (Psd, GPR12, GPR16, (Ofsimm (Ptrofs.of_int @@ Int.intval Z0)))) + in let bb = { header = []; body = [sd_inst]; exit = None } + in List.iter print_bb (smart_schedule bb) + +let _ = test_schedule_sd; printf "Done\n" diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v deleted file mode 100644 index 1a15b733..00000000 --- a/mppa_k1c/Archi.v +++ /dev/null @@ -1,80 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *) - -Require Import ZArith List. -Require Import Binary Bits. - -Definition ptr64 := true. - -Definition big_endian := false. - -Definition align_int64 := 8%Z. -Definition align_float64 := 8%Z. - -Definition splitlong := false. - -Lemma splitlong_ptr32: splitlong = true -> ptr64 = false. -Proof. - unfold splitlong. congruence. -Qed. - -(** FIXME - Check the properties below *) - -(** Section 7.3: "Except when otherwise stated, if the result of a - floating-point operation is NaN, it is the canonical NaN. The - canonical NaN has a positive sign and all significand bits clear - except the MSB, a.k.a. the quiet bit." - We need to extend the [choose_binop_pl] functions to account for - this case. *) - -Definition default_nan_64 := (false, iter_nat 51 _ xO xH). -Definition default_nan_32 := (false, iter_nat 22 _ xO xH). - -(* Always choose the first NaN argument, if any *) - -Definition choose_nan_64 (l: list (bool * positive)) : bool * positive := - match l with nil => default_nan_64 | n :: _ => n end. - -Definition choose_nan_32 (l: list (bool * positive)) : bool * positive := - match l with nil => default_nan_32 | n :: _ => n end. - -Definition fpu_returns_default_qNaN := false. - -Lemma choose_nan_64_idem: forall n, - choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil). -Proof. auto. Qed. - -Lemma choose_nan_32_idem: forall n, - choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil). -Proof. auto. Qed. - -Definition fma_order {A: Type} (x y z: A) := (x, z, y). - -Definition fma_invalid_mul_is_nan := false. -Definition float_of_single_preserves_sNaN := false. - -Global Opaque ptr64 big_endian splitlong - default_nan_64 choose_nan_64 - default_nan_32 choose_nan_32 - fma_order fma_invalid_mul_is_nan - float_of_single_preserves_sNaN. - -(** Whether to generate position-independent code or not *) - -Parameter pic_code: unit -> bool. - -Definition has_notrap_loads := true. diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v deleted file mode 100644 index c8c0bc1c..00000000 --- a/mppa_k1c/Asm.v +++ /dev/null @@ -1,751 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** * Abstract syntax for K1c textual assembly language. - - Each emittable instruction is defined here. ';;' is also defined as an instruction. - The goal of this representation is to stay compatible with the rest of the generic backend of CompCert - We define [unfold : list bblock -> list instruction] - An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code] - [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Asmvliw. -Require Import Linking. -Require Import Errors. - -(** Definitions for OCaml code *) -Definition label := positive. -Definition preg := preg. - -Inductive addressing : Type := - | AOff (ofs: offset) - | AReg (ro: ireg) - | ARegXS (ro: ireg) -. - -(** Syntax *) -Inductive instruction : Type := - (** pseudo instructions *) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Plabel (lbl: label) (**r define a code label *) - | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> instruction (**r built-in function (pseudo) *) - | Psemi (**r semi colon separating bundles *) - | Pnop (**r instruction that does nothing *) - - (** Control flow instructions *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (rs: ireg) (**r function call on register *) - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (rs: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) - | Pjumptable (r: ireg) (labels: list label) - - (* For builtins *) - | Ploopdo (count: ireg) (loopend: label) - | Pgetn (n: int) (dst: ireg) - | Psetn (n: int) (src: ireg) - | Pwfxl (n: int) (src: ireg) - | Pwfxm (n: int) (src: ireg) - | Pldu (dst: ireg) (addr: ireg) - | Plbzu (dst: ireg) (addr: ireg) - | Plhzu (dst: ireg) (addr: ireg) - | Plwzu (dst: ireg) (addr: ireg) - | Pawait - | Psleep - | Pstop - | Pbarrier - | Pfence - | Pdinval - | Pdinvall (addr: ireg) - | Pdtouchl (addr: ireg) - | Piinval - | Piinvals (addr: ireg) - | Pitouchl (addr: ireg) - | Pdzerol (addr: ireg) -(*| Pafaddd (addr: ireg) (incr_res: ireg) - | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *) - | Palclrd (dst: ireg) (addr: ireg) - | Palclrw (dst: ireg) (addr: ireg) - | Pclzll (rd rs: ireg) - | Pstsud (rd rs1 rs2: ireg) - - (** Loads **) - | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *) - | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *) - | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *) - | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *) - | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *) - | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *) - | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *) - | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *) - | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *) - | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *) - | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *) - | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *) - - (** Stores **) - | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *) - | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *) - | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *) - | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *) - | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *) - | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *) - | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *) - | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *) - - | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *) - - (** Arith RR *) - | Pmv (rd rs: ireg) (**r register move *) - | Pnegw (rd rs: ireg) (**r negate word *) - | Pnegl (rd rs: ireg) (**r negate long *) - | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *) - | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *) - | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *) - - | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *) - | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *) - - | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *) - - | Pfabsd (rd rs: ireg) (**r float absolute double *) - | Pfabsw (rd rs: ireg) (**r float absolute word *) - | Pfnegd (rd rs: ireg) (**r float negate double *) - | Pfnegw (rd rs: ireg) (**r float negate word *) - | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *) - | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *) - | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *) - | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *) - | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *) - | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *) - | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *) - | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *) - | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *) - | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *) - | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *) - - (** Arith RI32 *) - | Pmake (rd: ireg) (imm: int) (**r load immediate *) - - (** Arith RI64 *) - | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *) - - (** Arith RF32 *) - | Pmakefs (rd: ireg) (imm: float32) - - (** Arith RF64 *) - | Pmakef (rd: ireg) (imm: float) - - (** Arith RRR *) - | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *) - | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *) - | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *) - | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *) - - | Paddw (rd rs1 rs2: ireg) (**r add word *) - | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Psubw (rd rs1 rs2: ireg) (**r sub word *) - | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *) - | Pmulw (rd rs1 rs2: ireg) (**r mul word *) - | Pandw (rd rs1 rs2: ireg) (**r and word *) - | Pnandw (rd rs1 rs2: ireg) (**r nand word *) - | Porw (rd rs1 rs2: ireg) (**r or word *) - | Pnorw (rd rs1 rs2: ireg) (**r nor word *) - | Pxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pnxorw (rd rs1 rs2: ireg) (**r xor word *) - | Pandnw (rd rs1 rs2: ireg) (**r andn word *) - | Pornw (rd rs1 rs2: ireg) (**r orn word *) - | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *) - | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*) - | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *) - | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *) - | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *) - | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *) - | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *) - | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *) - | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *) - - | Paddl (rd rs1 rs2: ireg) (**r add long *) - | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *) - | Psubl (rd rs1 rs2: ireg) (**r sub long *) - | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *) - | Pandl (rd rs1 rs2: ireg) (**r and long *) - | Pnandl (rd rs1 rs2: ireg) (**r nand long *) - | Porl (rd rs1 rs2: ireg) (**r or long *) - | Pnorl (rd rs1 rs2: ireg) (**r nor long *) - | Pxorl (rd rs1 rs2: ireg) (**r xor long *) - | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *) - | Pandnl (rd rs1 rs2: ireg) (**r andn long *) - | Pornl (rd rs1 rs2: ireg) (**r orn long *) - | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *) - | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *) - | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *) - | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *) - | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*) - | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *) - | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *) - - | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *) - | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *) - | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *) - | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *) - | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *) - | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *) - | Pfmind (rd rs1 rs2: ireg) (**r Float min double *) - | Pfminw (rd rs1 rs2: ireg) (**r Float min word *) - | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *) - | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *) - | Pfinvw (rd rs1: ireg) (**r Float invert word *) - - (** Arith RRI32 *) - | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *) - - | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *) - | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *) - | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *) - | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *) - | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *) - | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *) - | Poriw (rd rs: ireg) (imm: int) (**r or imm word *) - | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *) - | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *) - | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *) - | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *) - | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *) - | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *) - | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *) - | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *) - | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *) - | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *) - | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *) - | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*) - | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *) - | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *) - - (** Arith RRI64 *) - | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *) - | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *) - | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *) - | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *) - | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *) - | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *) - | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *) - | Pornil (rd rs: ireg) (imm: int64) (**r orn long *) - | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *) - | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *) - | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *) - | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *) - | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *) - | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *) - | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *) -. - -(** Correspondance between Asmblock and Asm *) - -Definition control_to_instruction (c: control) := - match c with - | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res - | PCtlFlow Asmvliw.Pret => Pret - | PCtlFlow (Asmvliw.Pcall l) => Pcall l - | PCtlFlow (Asmvliw.Picall r) => Picall r - | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l - | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l - | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l - | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l - | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l - | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label - end. - -Definition basic_to_instruction (b: basic) := - match b with - (** Special basics *) - | Asmvliw.Pget rd rs => Pget rd rs - | Asmvliw.Pset rd rs => Pset rd rs - | Asmvliw.Pnop => Pnop - | Asmvliw.Pallocframe sz pos => Pallocframe sz pos - | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos - - (** PArith basics *) - (* R *) - | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs - - (* RR *) - | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs - | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs - | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs - | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs - | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs - | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs - | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start - | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start - | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start - | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start - | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs - | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs - | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs - | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs - | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs - | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs - | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs - | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs - | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs - | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs - | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs - | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs - | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs - | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs - | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs - | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs - - (* RI32 *) - | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm - - (* RI64 *) - | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm - - (* RF32 *) - | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm - - (* RF64 *) - | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm - - (* RRR *) - | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2 - | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2 - | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2 - | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2 - | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2 - | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2 - | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2 - | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2 - | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2 - | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2 - | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2 - | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2 - | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2 - | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2 - | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2 - - | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2 - | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2 - | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2 - | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2 - | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2 - | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2 - | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2 - | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2 - | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2 - | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2 - | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2 - | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2 - | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2 - | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2 - | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2 - - | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2 - | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2 - | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2 - | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2 - | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2 - | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2 - - (* RRI32 *) - | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm - | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm - | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm - | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm - | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm - | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm - | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm - | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm - | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm - | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm - | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm - | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm - | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm - | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm - | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm - | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm - | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm - | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm - | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm - | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm - | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm - | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm - | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm - - (* RRI64 *) - | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm - | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm - | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm - | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm - | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm - | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm - | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm - | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm - | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm - | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm - | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm - | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm - | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm - | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm - - (** ARRR *) - | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2 - | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2 - | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2 - | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2 - | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2 - - (** ARR *) - | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start - | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start - - (** ARRI32 *) - | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm - | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm - - (** ARRI64 *) - | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm - | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm - (** Load *) - | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs) - | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs) - - | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs) - | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs) - - | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro) - | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro) - - | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro) - | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro) - - (** Store *) - | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs) - | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs) - | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs) - - | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro) - | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro) - | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro) - | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro) - | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro) - - | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro) - | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro) - - | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs) - | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs) - end. - -Section RELSEM. - -Definition code := list instruction. - -Fixpoint unfold_label (ll: list label) := - match ll with - | nil => nil - | l :: ll => Plabel l :: unfold_label ll - end. - -Fixpoint unfold_body (lb: list basic) := - match lb with - | nil => nil - | b :: lb => basic_to_instruction b :: unfold_body lb - end. - -Definition unfold_exit (oc: option control) := - match oc with - | None => nil - | Some c => control_to_instruction c :: nil - end. - -Definition unfold_bblock (b: bblock) := unfold_label (header b) ++ - (match (body b), (exit b) with - | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None => - unfold_body bo - | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil - end). - -Fixpoint unfold (lb: bblocks) := - match lb with - | nil => nil - | b :: lb => (unfold_bblock b) ++ unfold lb - end. - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code; - correct: unfold fn_blocks = fn_code }. - -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. -Definition genv := Genv.t fundef unit. - -Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f). - -Definition fundef_proj (fu: fundef) : Asmvliw.fundef := - match fu with - | Internal f => Internal (function_proj f) - | External ef => External ef - end. - -Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit := - match gd with - | Gfun f => Gfun (fundef_proj f) - | Gvar gu => Gvar gu - end. - -Program Definition genv_trans (ge: genv) : Asmvliw.genv := - {| Genv.genv_public := Genv.genv_public ge; - Genv.genv_symb := Genv.genv_symb ge; - Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge); - Genv.genv_next := Genv.genv_next ge |}. -Next Obligation. - destruct ge. simpl in *. eauto. -Qed. Next Obligation. - destruct ge; simpl in *. - rewrite PTree.gmap1 in H. - destruct (genv_defs ! b) eqn:GEN. - - eauto. - - discriminate. -Qed. Next Obligation. - destruct ge; simpl in *. - eauto. -Qed. - -Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit)) - : list (ident * globdef Asmvliw.fundef unit) := - match l with - | nil => nil - | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l - end. - -Definition program_proj (p: program) : Asmvliw.program := - {| prog_defs := prog_defs_proj (prog_defs p); - prog_public := prog_public p; - prog_main := prog_main p - |}. - -End RELSEM. - -Definition semantics (p: program) := Asmvliw.semantics (program_proj p). - -(** Determinacy of the [Asm] semantics. *) - -Lemma semantics_determinate: forall p, determinate (semantics p). -Proof. - intros. apply semantics_determinate. -Qed. - -(** transf_program *) - -Program Definition transf_function (f: Asmvliw.function) : function := - {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f; - fn_code := unfold (Asmvliw.fn_blocks f) |}. - -Lemma transf_function_proj: forall f, function_proj (transf_function f) = f. -Proof. - intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto. -Qed. - -Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function. - -Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f. -Proof. - intros f. destruct f as [f|e]; simpl; auto. - rewrite transf_function_proj. auto. -Qed. - -Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef. - -Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B), - prog_defs p1 = prog_defs p2 -> - prog_public p1 = prog_public p2 -> - prog_main p1 = prog_main p2 -> - p1 = p2. -Proof. - intros. destruct p1. destruct p2. simpl in *. subst. auto. -Qed. - -Lemma transf_program_proj: forall p, program_proj (transf_program p) = p. -Proof. - intros p. destruct p as [defs pub main]. unfold program_proj. simpl. - apply program_equals; simpl; auto. - induction defs. - - simpl; auto. - - simpl. rewrite IHdefs. - destruct a as [id gd]; simpl. - destruct gd as [f|v]; simpl; auto. - rewrite transf_fundef_proj. auto. -Qed. - -Definition match_prog (p: Asmvliw.program) (tp: program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l. -Proof. - intros. congruence. -Qed. - -Lemma match_program_transf: - forall p tp, match_prog p tp -> transf_program p = tp. -Proof. - intros p tp H. inversion_clear H. inv H1. - destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *. - subst. unfold transf_program. unfold transform_program. simpl. - apply program_equals; simpl; auto. - induction H0; simpl; auto. - rewrite IHlist_forall2. apply cons_extract. - destruct a1 as [ida gda]. destruct b1 as [idb gdb]. - simpl in *. - inv H. inv H2. - - simpl in *. subst. auto. - - simpl in *. subst. inv H. auto. -Qed. - -Section PRESERVATION. - -Variable prog: Asmvliw.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Definition match_states (s1 s2: state) := s1 = s2. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - - -Theorem transf_program_correct: - forward_simulation (Asmvliw.semantics prog) (semantics tprog). -Proof. - pose proof (match_program_transf prog tprog TRANSF) as TR. - subst. unfold semantics. rewrite transf_program_proj. - - eapply forward_simulation_step with (match_states := match_states); simpl; auto. - - intros. exists s1. split; auto. congruence. - - intros. inv H. auto. - - intros. exists s1'. inv H0. split; auto. congruence. -Qed. - -End PRESERVATION. diff --git a/mppa_k1c/AsmToJSON.ml b/mppa_k1c/AsmToJSON.ml deleted file mode 100644 index 8a6a97a7..00000000 --- a/mppa_k1c/AsmToJSON.ml +++ /dev/null @@ -1,23 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Bernhard Schommer, AbsInt Angewandte Informatik GmbH *) -(* *) -(* AbsInt Angewandte Informatik GmbH. All rights reserved. This file *) -(* is distributed under the terms of the INRIA Non-Commercial *) -(* License Agreement. *) -(* *) -(* *********************************************************************) - -(* Simple functions to serialize RISC-V Asm to JSON *) - -(* Dummy function *) -let destination: string option ref = ref None - -let sdump_folder = ref "" - -let print_if prog sourcename = - () - -let pp_mnemonics pp = () diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v deleted file mode 100644 index 2abd445e..00000000 --- a/mppa_k1c/Asmaux.v +++ /dev/null @@ -1,19 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Asm. -Require Import AST. - -(** Constant only needed by Asmexpandaux.ml *) -Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}. diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v deleted file mode 100644 index 885ac6bc..00000000 --- a/mppa_k1c/Asmblock.v +++ /dev/null @@ -1,393 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Sequential block semantics for K1c assembly. The syntax is given in AsmVLIW *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Errors. -Require Export Asmvliw. - -(* Notations necessary to hook Asmvliw definitions *) -Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs. -Notation regset := Asmvliw.regset. -Notation extcall_arg := Asmvliw.extcall_arg. -Notation extcall_arg_pair := Asmvliw.extcall_arg_pair. -Notation extcall_arguments := Asmvliw.extcall_arguments. -Notation set_res := Asmvliw.set_res. -Notation function := Asmvliw.function. -Notation bblocks := Asmvliw.bblocks. -Notation header := Asmvliw.header. -Notation body := Asmvliw.body. -Notation exit := Asmvliw.exit. -Notation correct := Asmvliw.correct. - -(** * Auxiliary utilies on basic blocks *) - -(** ** A unified view of Kalray instructions *) - -Inductive instruction : Type := - | PBasic (i: basic) - | PControl (i: control) -. - -Coercion PBasic: basic >-> instruction. -Coercion PControl: control >-> instruction. - -Definition code := list instruction. -Definition bcode := list basic. - -Fixpoint basics_to_code (l: list basic) := - match l with - | nil => nil - | bi::l => (PBasic bi)::(basics_to_code l) - end. - -Fixpoint code_to_basics (c: code) := - match c with - | (PBasic i)::c => - match code_to_basics c with - | None => None - | Some l => Some (i::l) - end - | _::c => None - | nil => Some nil - end. - -Lemma code_to_basics_id: forall c, code_to_basics (basics_to_code c) = Some c. -Proof. - intros. induction c as [|i c]; simpl; auto. - rewrite IHc. auto. -Qed. - -Lemma code_to_basics_dist: - forall c c' l l', - code_to_basics c = Some l -> - code_to_basics c' = Some l' -> - code_to_basics (c ++ c') = Some (l ++ l'). -Proof. - induction c as [|i c]; simpl; auto. - - intros. inv H. simpl. auto. - - intros. destruct i; try discriminate. destruct (code_to_basics c) eqn:CTB; try discriminate. - inv H. erewrite IHc; eauto. auto. -Qed. - -(** - Asmblockgen will have to translate a Mach control into a list of instructions of the form - i1 :: i2 :: i3 :: ctl :: nil ; where i1..i3 are basic instructions, ctl is a control instruction - These functions provide way to extract the basic / control instructions -*) - -Fixpoint extract_basic (c: code) := - match c with - | nil => nil - | PBasic i :: c => i :: (extract_basic c) - | PControl i :: c => nil - end. - -Fixpoint extract_ctl (c: code) := - match c with - | nil => None - | PBasic i :: c => extract_ctl c - | PControl i :: nil => Some i - | PControl i :: _ => None (* if the first found control instruction isn't the last *) - end. - -(** ** Wellformness of basic blocks *) - -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - -Definition non_empty_bblock (body: list basic) (exit: option control): Prop - := body <> nil \/ exit <> None. - -Lemma non_empty_bblock_refl: - forall body exit, - non_empty_bblock body exit <-> - Is_true (non_empty_bblockb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. intros. inversion H; contradiction. - - destruct body; destruct exit. - all: simpl; auto. - all: intros; try (right; discriminate); try (left; discriminate). - contradiction. -Qed. - -Definition builtin_alone (body: list basic) (exit: option control) := forall ef args res, - exit = Some (PExpand (Pbuiltin ef args res)) -> body = nil. - - -Lemma builtin_alone_refl: - forall body exit, - builtin_alone body exit <-> Is_true (builtin_aloneb body exit). -Proof. - intros. split. - - destruct body; destruct exit. - all: simpl; auto. - all: exploreInst; simpl; auto. - unfold builtin_alone. intros. assert (Some (Pbuiltin e l b0) = Some (Pbuiltin e l b0)); auto. - assert (b :: body = nil). eapply H; eauto. discriminate. - - destruct body; destruct exit. - all: simpl; auto; try constructor. - + exploreInst; try discriminate. - simpl. contradiction. - + intros. discriminate. -Qed. - -Definition wf_bblock (body: list basic) (exit: option control) := - non_empty_bblock body exit /\ builtin_alone body exit. - -Lemma wf_bblock_refl: - forall body exit, - wf_bblock body exit <-> Is_true (wf_bblockb body exit). -Proof. - intros. split. - - intros. inv H. apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - apply andb_prop_intro. auto. - - intros. apply andb_prop_elim in H. inv H. - apply non_empty_bblock_refl in H0. apply builtin_alone_refl in H1. - unfold wf_bblock. split; auto. -Qed. - -Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)). - -Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2. -Proof. - destruct b; simpl; auto. - - destruct p1, p2; auto. - - destruct p1. -Qed. - -Lemma bblock_equality bb1 bb2: header bb1=header bb2 -> body bb1 = body bb2 -> exit bb1 = exit bb2 -> bb1 = bb2. -Proof. - destruct bb1 as [h1 b1 e1 c1], bb2 as [h2 b2 e2 c2]; simpl. - intros; subst. - rewrite (Istrue_proof_irrelevant _ c1 c2). - auto. -Qed. - -Program Definition bblock_single_inst (i: instruction) := - match i with - | PBasic b => {| header:=nil; body:=(b::nil); exit:=None |} - | PControl ctl => {| header:=nil; body:=nil; exit:=(Some ctl) |} - end. -Next Obligation. - apply wf_bblock_refl. constructor. - right. discriminate. - constructor. -Qed. - -Lemma length_nonil {A: Type} : forall l:(list A), l <> nil -> (length l > 0)%nat. -Proof. - intros. destruct l; try (contradict H; auto; fail). - simpl. omega. -Qed. - -Lemma to_nat_pos : forall z:Z, (Z.to_nat z > 0)%nat -> z > 0. -Proof. - intros. destruct z; auto. - - contradict H. simpl. apply gt_irrefl. - - apply Zgt_pos_0. - - contradict H. simpl. apply gt_irrefl. -Qed. - -Lemma size_positive (b:bblock): size b > 0. -Proof. - unfold size. destruct b as [hd bdy ex cor]. simpl. - destruct ex; destruct bdy; try (apply to_nat_pos; rewrite Nat2Z.id; simpl; omega). - inversion cor; contradict H; simpl; auto. -Qed. - - -Program Definition no_header (bb : bblock) := {| header := nil; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma no_header_size: - forall bb, size (no_header bb) = size bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. unfold no_header. simpl. reflexivity. -Qed. - -Program Definition stick_header (h : list label) (bb : bblock) := {| header := h; body := body bb; exit := exit bb |}. -Next Obligation. - destruct bb; simpl. assumption. -Defined. - -Lemma stick_header_size: - forall h bb, size (stick_header h bb) = size bb. -Proof. - intros. destruct bb. unfold stick_header. simpl. reflexivity. -Qed. - -Lemma stick_header_no_header: - forall bb, stick_header (header bb) (no_header bb) = bb. -Proof. - intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity. -Qed. - -(** * Sequential Semantics of basic blocks *) -Section RELSEM. - -(** Execution of arith instructions *) - -Variable ge: genv. - -Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec_arith_instr ge ai rs rs. - -(** Auxiliaries for memory accesses *) - -Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs. - -Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro. - -Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro. - -Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs. - -Definition exec_load_o_offset (rs: regset) (m: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := parexec_load_o_offset rs rs m m d a ofs. - -Definition exec_store_offset (chunk: memory_chunk) (rs: regset) (m: mem) (s a: ireg) (ofs: offset) := parexec_store_offset chunk rs rs m m s a ofs. - -Definition exec_store_q_offset (rs: regset) (m: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := parexec_store_q_offset rs rs m m s a ofs. - -Definition exec_store_o_offset (rs: regset) (m: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := parexec_store_o_offset rs rs m m s a ofs. - -Definition exec_store_reg (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_reg chunk rs rs m m s a ro. - -Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro: ireg) := parexec_store_regxs chunk rs rs m m s a ro. - -(** * basic instructions *) - -Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := bstep ge bi rs rs m m. - -Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome := - match body with - | nil => Next rs m - | bi::body' => - match exec_basic_instr bi rs m with - | Next rs' m' => exec_body body' rs' m' - | Stuck => Stuck - end - end. - - -Theorem builtin_body_nil: - forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil. -Proof. - intros. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1. - eapply H1; eauto. -Qed. - -Theorem exec_body_app: - forall l l' rs m rs'' m'', - exec_body (l ++ l') rs m = Next rs'' m'' -> - exists rs' m', - exec_body l rs m = Next rs' m' - /\ exec_body l' rs' m' = Next rs'' m''. -Proof. - induction l. - - intros. simpl in H. repeat eexists. auto. - - intros. rewrite <- app_comm_cons in H. simpl in H. - destruct (exec_basic_instr a rs m) eqn:EXEBI. - + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2). - repeat eexists. simpl. rewrite EXEBI. eauto. auto. - + discriminate. -Qed. - -(** Position corresponding to a label *) - -Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m. - -Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res. - -Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m. - -Definition exec_bblock (f: function) (b: bblock) (rs0: regset) (m: mem) : outcome := - match exec_body (body b) rs0 m with - | Next rs' m' => - let rs1 := nextblock b rs' in exec_control f (exit b) rs1 m' - | Stuck => Stuck - end. - - -(** Execution of the instruction at [rs PC]. *) - -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: - forall b ofs f bi rs m rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bi -> - exec_bblock f bi rs m = Next rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m' bi, - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> - exit bi = Some (PExpand (Pbuiltin ef args res)) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = nextblock bi - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#RTMP <- Vundef))) -> - step (State rs m) t (State rs' m') - | exec_step_external: - forall b ef args res rs m t rs' m', - rs PC = Vptr b Ptrofs.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - external_call ef ge args m t res m' -> - extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> - step (State rs m) t (State rs' m') - . - -End RELSEM. - -Definition semantics (p: program) := - Semantics step (initial_state p) final_state (Genv.globalenv p). - -Definition data_preg (r: preg) : bool := - match r with - | RA => false - | IR GPRA => false - | IR RTMP => false - | IR _ => true - | PC => false - end. diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v deleted file mode 100644 index 1881e7e9..00000000 --- a/mppa_k1c/Asmblockdeps.v +++ /dev/null @@ -1,1833 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** * Translation from Asmblock to AbstractBB - - We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance - AbstractBB will then define two semantics for L : a sequential, and a semantic one - We prove a bisimulation between the parallel semantics of L and AsmVLIW - From this, we also deduce a bisimulation between the sequential semantics of L and Asmblock *) - -Require Import AST. -Require Import Asmblock. -Require Import Asmblockgenproof0 Asmblockprops. -Require Import Values. -Require Import Globalenvs. -Require Import Memory. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import ZArith. -Require Import Coqlib. -Require Import ImpSimuTest. -Require Import Axioms. -Require Import Parallelizability. -Require Import Asmvliw Permutation. -Require Import Chunks. - -Require Import Lia. - -Open Scope impure. - -(** Definition of L *) - -Module P<: ImpParam. -Module R := Pos. - -Section IMPPARAM. - -Definition env := Genv.t fundef unit. - -Inductive genv_wrap := Genv (ge: env) (fn: function). -Definition genv := genv_wrap. - -Variable Ge: genv. - -Inductive value_wrap := - | Val (v: val) - | Memstate (m: mem) -. - -Definition value := value_wrap. - -Inductive control_op := - | Oj_l (l: label) - | Ocb (bt: btest) (l: label) - | Ocbu (bt: btest) (l: label) - | Odiv - | Odivu - | OError - | OIncremPC (sz: Z) - | Ojumptable (l: list label) -. - -Inductive arith_op := - | OArithR (n: arith_name_r) - | OArithRR (n: arith_name_rr) - | OArithRI32 (n: arith_name_ri32) (imm: int) - | OArithRI64 (n: arith_name_ri64) (imm: int64) - | OArithRF32 (n: arith_name_rf32) (imm: float32) - | OArithRF64 (n: arith_name_rf64) (imm: float) - | OArithRRR (n: arith_name_rrr) - | OArithRRI32 (n: arith_name_rri32) (imm: int) - | OArithRRI64 (n: arith_name_rri64) (imm: int64) - | OArithARRR (n: arith_name_arrr) - | OArithARR (n: arith_name_arr) - | OArithARRI32 (n: arith_name_arri32) (imm: int) - | OArithARRI64 (n: arith_name_arri64) (imm: int64) -. - -Coercion OArithR: arith_name_r >-> arith_op. -Coercion OArithRR: arith_name_rr >-> arith_op. -Coercion OArithRI32: arith_name_ri32 >-> Funclass. -Coercion OArithRI64: arith_name_ri64 >-> Funclass. -Coercion OArithRF32: arith_name_rf32 >-> Funclass. -Coercion OArithRF64: arith_name_rf64 >-> Funclass. -Coercion OArithRRR: arith_name_rrr >-> arith_op. -Coercion OArithRRI32: arith_name_rri32 >-> Funclass. -Coercion OArithRRI64: arith_name_rri64 >-> Funclass. - -Inductive load_op := - | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset) - | OLoadRRR (n: load_name) (trap: trapping_mode) - | OLoadRRRXS (n: load_name) (trap: trapping_mode) -. - -Coercion OLoadRRO: load_name >-> Funclass. - -Inductive store_op := - | OStoreRRO (n: store_name) (ofs: offset) - | OStoreRRR (n: store_name) - | OStoreRRRXS (n: store_name) -. - -Coercion OStoreRRO: store_name >-> Funclass. - -Inductive op_wrap := - | Arith (ao: arith_op) - | Load (lo: load_op) - | Store (so: store_op) - | Control (co: control_op) - | Allocframe (sz: Z) (pos: ptrofs) - | Allocframe2 (sz: Z) (pos: ptrofs) - | Freeframe (sz: Z) (pos: ptrofs) - | Freeframe2 (sz: Z) (pos: ptrofs) - | Constant (v: val) - | Fail -. - -Coercion Arith: arith_op >-> op_wrap. -Coercion Load: load_op >-> op_wrap. -Coercion Store: store_op >-> op_wrap. -Coercion Control: control_op >-> op_wrap. - -Definition op := op_wrap. - -Definition arith_eval (ao: arith_op) (l: list value) := - let (ge, fn) := Ge in - match ao, l with - | OArithR n, [] => Some (Val (arith_eval_r ge n)) - - | OArithRR n, [Val v] => Some (Val (arith_eval_rr n v)) - - | OArithRI32 n i, [] => Some (Val (arith_eval_ri32 n i)) - | OArithRI64 n i, [] => Some (Val (arith_eval_ri64 n i)) - | OArithRF32 n i, [] => Some (Val (arith_eval_rf32 n i)) - | OArithRF64 n i, [] => Some (Val (arith_eval_rf64 n i)) - - | OArithRRR n, [Val v1; Val v2] => Some (Val (arith_eval_rrr n v1 v2)) - | OArithRRI32 n i, [Val v] => Some (Val (arith_eval_rri32 n v i)) - | OArithRRI64 n i, [Val v] => Some (Val (arith_eval_rri64 n v i)) - - | OArithARR n, [Val v1; Val v2] => Some (Val (arith_eval_arr n v1 v2)) - | OArithARRR n, [Val v1; Val v2; Val v3] => Some (Val (arith_eval_arrr n v1 v2 v3)) - | OArithARRI32 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri32 n v1 v2 i)) - | OArithARRI64 n i, [Val v1; Val v2] => Some (Val (arith_eval_arri64 n v1 v2 i)) - - | _, _ => None - end. - -Definition exec_incorrect_load trap chunk := - match trap with - | TRAP => None - | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk)) - end. - -Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) := - let (ge, fn) := Ge in - match (eval_offset ofs) with - | OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with - | None => exec_incorrect_load trap chunk - | Some vl => Some (Val vl) - end - | _ => None - end. - -Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := - match Mem.loadv chunk m (Val.addl v vo) with - | None => exec_incorrect_load trap chunk - | Some vl => Some (Val vl) - end. - -Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) := - match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with - | None => exec_incorrect_load trap chunk - | Some vl => Some (Val vl) - end. - -Definition load_eval (lo: load_op) (l: list value) := - match lo, l with - | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs - | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo - | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo - | _, _ => None - end. - -Definition exec_store_deps_offset (chunk: memory_chunk) (m: mem) (vs va: val) (ofs: offset) := - let (ge, fn) := Ge in - match (eval_offset ofs) with - | OK ptr => match Mem.storev chunk m (Val.offset_ptr va ptr) vs with - | None => None - | Some m' => Some (Memstate m') - end - | _ => None - end. - -Definition exec_store_deps_reg (chunk: memory_chunk) (m: mem) (vs va vo: val) := - match Mem.storev chunk m (Val.addl va vo) vs with - | None => None - | Some m' => Some (Memstate m') - end. - -Definition exec_store_deps_regxs (chunk: memory_chunk) (m: mem) (vs va vo: val) := - match Mem.storev chunk m (Val.addl va (Val.shll vo (scale_of_chunk chunk))) vs with - | None => None - | Some m' => Some (Memstate m') - end. - -Definition store_eval (so: store_op) (l: list value) := - match so, l with - | OStoreRRO n ofs, [Val vs; Val va; Memstate m] => exec_store_deps_offset (store_chunk n) m vs va ofs - | OStoreRRR n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_reg (store_chunk n) m vs va vo - | OStoreRRRXS n, [Val vs; Val va; Val vo; Memstate m] => exec_store_deps_regxs (store_chunk n) m vs va vo - | _, _ => None - end. - -Local Open Scope Z. - -Remark size_chunk_positive: forall chunk, - (size_chunk chunk) > 0. -Proof. - destruct chunk; simpl; lia. -Qed. - -Remark size_chunk_small: forall chunk, - (size_chunk chunk) <= 8. -Proof. - destruct chunk; simpl; lia. -Qed. - -Definition disjoint_chunks - (ofs1 : offset) (chunk1 : memory_chunk) - (ofs2 : offset) (chunk2 : memory_chunk) := - Intv.disjoint ((Ptrofs.unsigned ofs1), - ((Ptrofs.unsigned ofs1) + (size_chunk chunk1))) - ((Ptrofs.unsigned ofs2), - ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))). - -Definition small_offset_threshold := 18446744073709551608. - -Lemma store_store_disjoint_offsets : - forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2', - (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) -> - (Ptrofs.unsigned ofs1) < small_offset_threshold -> - (Ptrofs.unsigned ofs2) < small_offset_threshold -> - store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) -> - store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') -> - store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') -> - m2 = m2'. -Proof. - intros until m2'. - intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'. - unfold disjoint_chunks in DISJOINT. - destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence. - destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence. - destruct va as [base | ]; try congruence. - unfold exec_store_deps_offset in *. - destruct Ge. - unfold eval_offset in *; simpl in *. - unfold Mem.storev in *. - unfold Val.offset_ptr in *. - destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence. - inv STORE0. - destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence. - inv STORE1. - destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence. - inv STORE0'. - destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence. - inv STORE1'. - assert (Some m2 = Some m2'). - 2: congruence. - rewrite <- E1. - rewrite <- E1'. - eapply Mem.store_store_other. - 2, 3: eassumption. - - right. - pose proof (size_chunk_positive (store_chunk n1)). - pose proof (size_chunk_positive (store_chunk n2)). - pose proof (size_chunk_small (store_chunk n1)). - pose proof (size_chunk_small (store_chunk n2)). - destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; - unfold Intv.empty in DIS; simpl in DIS. - 1, 2: lia. - pose proof (Ptrofs.unsigned_range ofs1). - pose proof (Ptrofs.unsigned_range ofs2). - unfold small_offset_threshold in *. - destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; - destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; - change Ptrofs.modulus with 18446744073709551616 in *; - lia. -Qed. - -Lemma load_store_disjoint_offsets : - forall n1 n2 tm ofs1 ofs2 vs va m0 m1, - (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) -> - (Ptrofs.unsigned ofs1) < small_offset_threshold -> - (Ptrofs.unsigned ofs2) < small_offset_threshold -> - store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) -> - load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] = - load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0]. -Proof. - intros until m1. - intros DISJOINT SMALL1 SMALL2 STORE0. - destruct vs as [v | ]; simpl in STORE0; try congruence. - destruct va as [base | ]; try congruence. - unfold exec_store_deps_offset in *. - unfold eval_offset in *; simpl in *. - unfold exec_load_deps_offset. - unfold Mem.storev, Mem.loadv in *. - destruct Ge in *. - unfold eval_offset in *. - unfold Val.offset_ptr in *. - destruct base as [ | | | | | wblock wpofs] in * ; try congruence. - destruct (Mem.store _ _ _ _) eqn:E0; try congruence. - inv STORE0. - assert ( - (Mem.load (load_chunk n2) m1 wblock - (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) = - (Mem.load (load_chunk n2) m0 wblock - (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS. - { - eapply Mem.load_store_other. - eassumption. - right. - pose proof (size_chunk_positive (store_chunk n1)). - pose proof (size_chunk_positive (load_chunk n2)). - pose proof (size_chunk_small (store_chunk n1)). - pose proof (size_chunk_small (load_chunk n2)). - destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]]; - unfold Intv.empty in DIS; simpl in DIS. - 1,2: lia. - - pose proof (Ptrofs.unsigned_range ofs1). - pose proof (Ptrofs.unsigned_range ofs2). - unfold small_offset_threshold in *. - destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1; - destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2; - change Ptrofs.modulus with 18446744073709551616 in *; - lia. - } - destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence. -Qed. - -Definition goto_label_deps (f: function) (lbl: label) (vpc: val) := - match label_pos lbl 0 (fn_blocks f) with - | None => None - | Some pos => - match vpc with - | Vptr b ofs => Some (Val (Vptr b (Ptrofs.repr pos))) - | _ => None - end - end. - -Definition eval_branch_deps (f: function) (l: label) (vpc: val) (res: option bool) := - match res with - | Some true => goto_label_deps f l vpc - | Some false => Some (Val vpc) - | None => None - end. - -Definition control_eval (o: control_op) (l: list value) := - let (ge, fn) := Ge in - match o, l with - | (Ojumptable tbl), [Val index; Val vpc] => - match index with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => None - | Some lbl => goto_label_deps fn lbl vpc - end - | _ => None - end - | Oj_l l, [Val vpc] => goto_label_deps fn l vpc - | Ocb bt l, [Val v; Val vpc] => - match cmp_for_btest bt with - | (Some c, Int) => eval_branch_deps fn l vpc (Val.cmp_bool c v (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch_deps fn l vpc (Val.cmpl_bool c v (Vlong (Int64.repr 0))) - | (None, _) => None - end - | Ocbu bt l, [Val v; Val vpc] => - match cmpu_for_btest bt with - | (Some c, Int) => eval_branch_deps fn l vpc (Val_cmpu_bool c v (Vint (Int.repr 0))) - | (Some c, Long) => eval_branch_deps fn l vpc (Val_cmplu_bool c v (Vlong (Int64.repr 0))) - | (None, _) => None - end - | Odiv, [Val v1; Val v2] => - match Val.divs v1 v2 with - | Some v => Some (Val v) - | None => None - end - | Odivu, [Val v1; Val v2] => - match Val.divu v1 v2 with - | Some v => Some (Val v) - | None => None - end - | OIncremPC sz, [Val vpc] => Some (Val (Val.offset_ptr vpc (Ptrofs.repr sz))) - | OError, _ => None - | _, _ => None - end. - -Definition op_eval (o: op) (l: list value) := - match o, l with - | Arith o, l => arith_eval o l - | Load o, l => load_eval o l - | Store o, l => store_eval o l - | Control o, l => control_eval o l - | Allocframe sz pos, [Val spv; Memstate m] => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with - | None => None - | Some m => Some (Memstate m) - end - | Allocframe2 sz pos, [Val spv; Memstate m] => - let (m1, stk) := Mem.alloc m 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr m1 (Val.offset_ptr sp pos) spv with - | None => None - | Some m => Some (Val sp) - end - | Freeframe sz pos, [Val spv; Memstate m] => - match Mem.loadv Mptr m (Val.offset_ptr spv pos) with - | None => None - | Some v => - match spv with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => None - | Some m' => Some (Memstate m') - end - | _ => None - end - end - | Freeframe2 sz pos, [Val spv; Memstate m] => - match Mem.loadv Mptr m (Val.offset_ptr spv pos) with - | None => None - | Some v => - match spv with - | Vptr stk ofs => - match Mem.free m stk 0 sz with - | None => None - | Some m' => Some (Val v) - end - | _ => None - end - end - | Constant v, [] => Some (Val v) - | Fail, _ => None - | _, _ => None - end. - - -Definition arith_op_eq (o1 o2: arith_op): ?? bool := - match o1 with - | OArithR n1 => - match o2 with OArithR n2 => struct_eq n1 n2 | _ => RET false end - | OArithRR n1 => - match o2 with OArithRR n2 => phys_eq n1 n2 | _ => RET false end - | OArithRI32 n1 i1 => - match o2 with OArithRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithRI64 n1 i1 => - match o2 with OArithRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithRF32 n1 i1 => - match o2 with OArithRF32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithRF64 n1 i1 => - match o2 with OArithRF64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithRRR n1 => - match o2 with OArithRRR n2 => phys_eq n1 n2 | _ => RET false end - | OArithRRI32 n1 i1 => - match o2 with OArithRRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithRRI64 n1 i1 => - match o2 with OArithRRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithARRR n1 => - match o2 with OArithARRR n2 => phys_eq n1 n2 | _ => RET false end - | OArithARR n1 => - match o2 with OArithARR n2 => phys_eq n1 n2 | _ => RET false end - | OArithARRI32 n1 i1 => - match o2 with OArithARRI32 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - | OArithARRI64 n1 i1 => - match o2 with OArithARRI64 n2 i2 => iandb (phys_eq n1 n2) (phys_eq i1 i2) | _ => RET false end - end. - -Ltac my_wlp_simplify := wlp_xsimplify ltac:(intros; subst; simpl in * |- *; congruence || intuition eauto with wlp). - -Lemma arith_op_eq_correct o1 o2: - WHEN arith_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. -Proof. - destruct o1, o2; my_wlp_simplify; try congruence. -Qed. -Hint Resolve arith_op_eq_correct: wlp. -Opaque arith_op_eq_correct. - -Definition offset_eq (ofs1 ofs2 : offset): ?? bool := - RET (Ptrofs.eq ofs1 ofs2). - -Lemma offset_eq_correct ofs1 ofs2: - WHEN offset_eq ofs1 ofs2 ~> b THEN b = true -> ofs1 = ofs2. -Proof. - wlp_simplify. - pose (Ptrofs.eq_spec ofs1 ofs2). - rewrite H in *. - trivial. -Qed. -Hint Resolve offset_eq_correct: wlp. - -Definition trapping_mode_eq trap1 trap2 := - RET (match trap1, trap2 with - | TRAP, TRAP | NOTRAP, NOTRAP => true - | TRAP, NOTRAP | NOTRAP, TRAP => false - end). -Lemma trapping_mode_eq_correct t1 t2: - WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2. -Proof. - wlp_simplify. - destruct t1; destruct t2; trivial; discriminate. -Qed. -Hint Resolve trapping_mode_eq_correct: wlp. - -Definition load_op_eq (o1 o2: load_op): ?? bool := - match o1 with - | OLoadRRO n1 trap ofs1 => - match o2 with - | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2)) - | _ => RET false - end - | OLoadRRR n1 trap => - match o2 with - | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) - | _ => RET false - end - | OLoadRRRXS n1 trap => - match o2 with - | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2) - | _ => RET false - end - end. - -Lemma load_op_eq_correct o1 o2: - WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. -Proof. - destruct o1, o2; wlp_simplify; try discriminate. - { f_equal. - destruct trap, trap0; simpl in *; trivial; discriminate. - pose (Ptrofs.eq_spec ofs ofs0). - rewrite H in *. trivial. } - all: destruct trap, trap0; simpl in *; trivial; discriminate. -Qed. -Hint Resolve load_op_eq_correct: wlp. -Opaque load_op_eq_correct. - -Definition store_op_eq (o1 o2: store_op): ?? bool := - match o1 with - | OStoreRRO n1 ofs1 => - match o2 with OStoreRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end - | OStoreRRR n1 => - match o2 with OStoreRRR n2 => phys_eq n1 n2 | _ => RET false end - | OStoreRRRXS n1 => - match o2 with OStoreRRRXS n2 => phys_eq n1 n2 | _ => RET false end - end. - -Lemma store_op_eq_correct o1 o2: - WHEN store_op_eq o1 o2 ~> b THEN b = true -> o1 = o2. -Proof. - destruct o1, o2; wlp_simplify; try discriminate. - - f_equal. pose (Ptrofs.eq_spec ofs ofs0). - rewrite H in *. trivial. - - congruence. - - congruence. -Qed. -Hint Resolve store_op_eq_correct: wlp. -Opaque store_op_eq_correct. - -Definition control_op_eq (c1 c2: control_op): ?? bool := - match c1 with - | Oj_l l1 => - match c2 with Oj_l l2 => phys_eq l1 l2 | _ => RET false end - | Ocb bt1 l1 => - match c2 with Ocb bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end - | Ocbu bt1 l1 => - match c2 with Ocbu bt2 l2 => iandb (phys_eq bt1 bt2) (phys_eq l1 l2) | _ => RET false end - | Ojumptable tbl1 => - match c2 with Ojumptable tbl2 => phys_eq tbl1 tbl2 | _ => RET false end - | Odiv => - match c2 with Odiv => RET true | _ => RET false end - | Odivu => - match c2 with Odivu => RET true | _ => RET false end - | OIncremPC sz1 => - match c2 with OIncremPC sz2 => RET (Z.eqb sz1 sz2) | _ => RET false end - | OError => - match c2 with OError => RET true | _ => RET false end - end. - -Lemma control_op_eq_correct c1 c2: - WHEN control_op_eq c1 c2 ~> b THEN b = true -> c1 = c2. -Proof. - destruct c1, c2; wlp_simplify; try rewrite Z.eqb_eq in * |-; try congruence. -Qed. -Hint Resolve control_op_eq_correct: wlp. -Opaque control_op_eq_correct. - -Definition op_eq (o1 o2: op): ?? bool := - match o1 with - | Arith i1 => - match o2 with Arith i2 => arith_op_eq i1 i2 | _ => RET false end - | Load i1 => - match o2 with Load i2 => load_op_eq i1 i2 | _ => RET false end - | Store i1 => - match o2 with Store i2 => store_op_eq i1 i2 | _ => RET false end - | Control i1 => - match o2 with Control i2 => control_op_eq i1 i2 | _ => RET false end - | Allocframe sz1 pos1 => - match o2 with Allocframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end - | Allocframe2 sz1 pos1 => - match o2 with Allocframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end - | Freeframe sz1 pos1 => - match o2 with Freeframe sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end - | Freeframe2 sz1 pos1 => - match o2 with Freeframe2 sz2 pos2 => iandb (RET (Z.eqb sz1 sz2)) (phys_eq pos1 pos2) | _ => RET false end - | Constant c1 => - match o2 with Constant c2 => phys_eq c1 c2 | _ => RET false end - | Fail => - match o2 with Fail => RET true | _ => RET false end - end. - -Theorem op_eq_correct o1 o2: - WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2. -Proof. - destruct o1, o2; wlp_simplify; try rewrite Z.eqb_eq in * |- ; try congruence. -Qed. -Hint Resolve op_eq_correct: wlp. -Global Opaque op_eq_correct. - -End IMPPARAM. - -End P. - -Module L <: ISeqLanguage with Module LP:=P. - -Module LP:=P. - -Include MkSeqLanguage P. - -End L. - -Module IST := ImpSimu L ImpPosDict. - -Import L. -Import P. - -(** Compilation from Asmblock to L *) - -Local Open Scope positive_scope. - -Definition pmem : R.t := 1. - -Definition ireg_to_pos (ir: ireg) : R.t := - match ir with - | GPR0 => 1 | GPR1 => 2 | GPR2 => 3 | GPR3 => 4 | GPR4 => 5 | GPR5 => 6 | GPR6 => 7 | GPR7 => 8 | GPR8 => 9 | GPR9 => 10 - | GPR10 => 11 | GPR11 => 12 | GPR12 => 13 | GPR13 => 14 | GPR14 => 15 | GPR15 => 16 | GPR16 => 17 | GPR17 => 18 | GPR18 => 19 | GPR19 => 20 - | GPR20 => 21 | GPR21 => 22 | GPR22 => 23 | GPR23 => 24 | GPR24 => 25 | GPR25 => 26 | GPR26 => 27 | GPR27 => 28 | GPR28 => 29 | GPR29 => 30 - | GPR30 => 31 | GPR31 => 32 | GPR32 => 33 | GPR33 => 34 | GPR34 => 35 | GPR35 => 36 | GPR36 => 37 | GPR37 => 38 | GPR38 => 39 | GPR39 => 40 - | GPR40 => 41 | GPR41 => 42 | GPR42 => 43 | GPR43 => 44 | GPR44 => 45 | GPR45 => 46 | GPR46 => 47 | GPR47 => 48 | GPR48 => 49 | GPR49 => 50 - | GPR50 => 51 | GPR51 => 52 | GPR52 => 53 | GPR53 => 54 | GPR54 => 55 | GPR55 => 56 | GPR56 => 57 | GPR57 => 58 | GPR58 => 59 | GPR59 => 60 - | GPR60 => 61 | GPR61 => 62 | GPR62 => 63 | GPR63 => 64 - end -. - -Lemma ireg_to_pos_discr: forall r r', r <> r' -> ireg_to_pos r <> ireg_to_pos r'. -Proof. - destruct r; destruct r'; try contradiction; discriminate. -Qed. - -Definition ppos (r: preg) : R.t := - match r with - | RA => 2 - | PC => 3 - | IR ir => 3 + ireg_to_pos ir - end -. - -Notation "# r" := (ppos r) (at level 100, right associativity). - -Lemma not_eq_add: - forall k n n', n <> n' -> k + n <> k + n'. -Proof. - intros k n n' H1 H2. apply H1; clear H1. eapply Pos.add_reg_l; eauto. -Qed. - -Lemma ppos_discr: forall r r', r <> r' -> ppos r <> ppos r'. -Proof. - destruct r; destruct r'. - all: try discriminate; try contradiction. - - intros. apply not_eq_add. apply ireg_to_pos_discr. congruence. - - intros. unfold ppos. cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. - apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. - - intros. unfold ppos. rewrite Pos.add_comm. apply Pos.add_no_neutral. - - intros. unfold ppos. apply not_eq_sym. - cutrewrite (3 + ireg_to_pos g = (1 + ireg_to_pos g) + 2). apply Pos.add_no_neutral. - apply eq_sym. rewrite Pos.add_comm. rewrite Pos.add_assoc. reflexivity. - - intros. unfold ppos. apply not_eq_sym. rewrite Pos.add_comm. apply Pos.add_no_neutral. -Qed. - -Lemma ppos_pmem_discr: forall r, pmem <> ppos r. -Proof. - intros. destruct r. - - unfold ppos. unfold pmem. apply not_eq_sym. rewrite Pos.add_comm. cutrewrite (3 = 2 + 1). rewrite Pos.add_assoc. apply Pos.add_no_neutral. - reflexivity. - - unfold ppos. unfold pmem. discriminate. - - unfold ppos. unfold pmem. discriminate. -Qed. - -(** Inversion functions, used for debug traces *) - -Definition pos_to_ireg (p: R.t) : option gpreg := - match p with - | 1 => Some GPR0 | 2 => Some GPR1 | 3 => Some GPR2 | 4 => Some GPR3 | 5 => Some GPR4 | 6 => Some GPR5 | 7 => Some GPR6 | 8 => Some GPR7 | 9 => Some GPR8 | 10 => Some GPR9 - | 11 => Some GPR10 | 12 => Some GPR11 | 13 => Some GPR12 | 14 => Some GPR13 | 15 => Some GPR14 | 16 => Some GPR15 | 17 => Some GPR16 | 18 => Some GPR17 | 19 => Some GPR18 | 20 => Some GPR19 - | 21 => Some GPR20 | 22 => Some GPR21 | 23 => Some GPR22 | 24 => Some GPR23 | 25 => Some GPR24 | 26 => Some GPR25 | 27 => Some GPR26 | 28 => Some GPR27 | 29 => Some GPR28 | 30 => Some GPR29 - | 31 => Some GPR30 | 32 => Some GPR31 | 33 => Some GPR32 | 34 => Some GPR33 | 35 => Some GPR34 | 36 => Some GPR35 | 37 => Some GPR36 | 38 => Some GPR37 | 39 => Some GPR38 | 40 => Some GPR39 - | 41 => Some GPR40 | 42 => Some GPR41 | 43 => Some GPR42 | 44 => Some GPR43 | 45 => Some GPR44 | 46 => Some GPR45 | 47 => Some GPR46 | 48 => Some GPR47 | 49 => Some GPR48 | 50 => Some GPR49 - | 51 => Some GPR50 | 52 => Some GPR51 | 53 => Some GPR52 | 54 => Some GPR53 | 55 => Some GPR54 | 56 => Some GPR55 | 57 => Some GPR56 | 58 => Some GPR57 | 59 => Some GPR58 | 60 => Some GPR59 - | 61 => Some GPR60 | 62 => Some GPR61 | 63 => Some GPR62 | 64 => Some GPR63 - | _ => None - end. - -Definition inv_ppos (p: R.t) : option preg := - match p with - | 1 => None - | 2 => Some RA | 3 => Some PC - | n => match pos_to_ireg (n-3) with - | None => None - | Some gpr => Some (IR gpr) - end - end. - -Notation "a @ b" := (Econs a b) (at level 102, right associativity). - -Definition trans_control (ctl: control) : inst := - match ctl with - | Pret => [(#PC, PReg(#RA))] - | Pcall s => [(#RA, PReg(#PC)); (#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] - | Picall r => [(#RA, PReg(#PC)); (#PC, PReg(#r))] - | Pgoto s => [(#PC, Op (Arith (OArithR (Ploadsymbol s Ptrofs.zero))) Enil)] - | Pigoto r => [(#PC, PReg(#r))] - | Pj_l l => [(#PC, Op (Control (Oj_l l)) (PReg(#PC) @ Enil))] - | Pcb bt r l => [(#PC, Op (Control (Ocb bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] - | Pcbu bt r l => [(#PC, Op (Control (Ocbu bt l)) (PReg(#r) @ PReg(#PC) @ Enil))] - | Pjumptable r labels => [(#PC, Op (Control (Ojumptable labels)) (PReg(#r) @ PReg(#PC) @ Enil)); - (#GPR62, Op (Constant Vundef) Enil); - (#GPR63, Op (Constant Vundef) Enil) ] - | Pbuiltin ef args res => [(#PC, Op (Control (OError)) Enil)] - end. - -Definition trans_exit (ex: option control) : L.inst := - match ex with - | None => [] - | Some ctl => trans_control ctl - end -. - -Definition trans_arith (ai: ar_instruction) : inst := - match ai with - | PArithR n d => [(#d, Op (Arith (OArithR n)) Enil)] - | PArithRR n d s => [(#d, Op (Arith (OArithRR n)) (PReg(#s) @ Enil))] - | PArithRI32 n d i => [(#d, Op (Arith (OArithRI32 n i)) Enil)] - | PArithRI64 n d i => [(#d, Op (Arith (OArithRI64 n i)) Enil)] - | PArithRF32 n d i => [(#d, Op (Arith (OArithRF32 n i)) Enil)] - | PArithRF64 n d i => [(#d, Op (Arith (OArithRF64 n i)) Enil)] - | PArithRRR n d s1 s2 => [(#d, Op (Arith (OArithRRR n)) (PReg(#s1) @ PReg(#s2) @ Enil))] - | PArithRRI32 n d s i => [(#d, Op (Arith (OArithRRI32 n i)) (PReg(#s) @ Enil))] - | PArithRRI64 n d s i => [(#d, Op (Arith (OArithRRI64 n i)) (PReg(#s) @ Enil))] - | PArithARRR n d s1 s2 => [(#d, Op (Arith (OArithARRR n)) (PReg(#d) @ PReg(#s1) @ PReg(#s2) @ Enil))] - | PArithARR n d s => [(#d, Op (Arith (OArithARR n)) (PReg(#d) @ PReg(#s) @ Enil))] - | PArithARRI32 n d s i => [(#d, Op (Arith (OArithARRI32 n i)) (PReg(#d) @ PReg(#s) @ Enil))] - | PArithARRI64 n d s i => [(#d, Op (Arith (OArithARRI64 n i)) (PReg(#d) @ PReg(#s) @ Enil))] - end. - - -Definition trans_basic (b: basic) : inst := - match b with - | PArith ai => trans_arith ai - | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))] - | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))] - | PLoadQRRO qd a ofs => - let (d0, d1) := gpreg_q_expand qd in - [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] - | PLoadORRO od a ofs => - match gpreg_o_expand od with - | (d0, d1, d2, d3) => - [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil)); - (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil)); - (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))] - end - | PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))] - | PStoreQRRO qs a ofs => - let (s0, s1) := gpreg_q_expand qs in - [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); - (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil))] - | PStoreORRO os a ofs => - match gpreg_o_expand os with - | (s0, s1, s2, s3) => - [(pmem, Op (Store (OStoreRRO Psd_a ofs)) (PReg (#s0) @ PReg (#a) @ PReg pmem @ Enil)); - (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (PReg (#s1) @ PReg (#a) @ PReg pmem @ Enil)); - (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (PReg (#s2) @ PReg (#a) @ PReg pmem @ Enil)); - (pmem, Op (Store (OStoreRRO Psd_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (PReg (#s3) @ PReg (#a) @ PReg pmem @ Enil))] - end - | Pallocframe sz pos => [(#FP, PReg (#SP)); (#SP, Op (Allocframe2 sz pos) (PReg (#SP) @ PReg pmem @ Enil)); (#RTMP, Op (Constant Vundef) Enil); - (pmem, Op (Allocframe sz pos) (Old (PReg (#SP)) @ PReg pmem @ Enil))] - | Pfreeframe sz pos => [(pmem, Op (Freeframe sz pos) (PReg (#SP) @ PReg pmem @ Enil)); - (#SP, Op (Freeframe2 sz pos) (PReg (#SP) @ Old (PReg pmem) @ Enil)); - (#RTMP, Op (Constant Vundef) Enil)] - | Pget rd ra => match ra with - | RA => [(#rd, PReg(#ra))] - | _ => [(#rd, Op Fail Enil)] - end - | Pset ra rd => match ra with - | RA => [(#ra, PReg(#rd))] - | _ => [(#rd, Op Fail Enil)] - end - | Pnop => [] - end. - -Fixpoint trans_body (b: list basic) : list L.inst := - match b with - | nil => nil - | b :: lb => (trans_basic b) :: (trans_body lb) - end. - -Definition trans_pcincr (sz: Z) (k: L.inst) := (#PC, Op (Control (OIncremPC sz)) (PReg(#PC) @ Enil)) :: k. - -Definition trans_block (b: Asmvliw.bblock) : L.bblock := - trans_body (body b) ++ (trans_pcincr (size b) (trans_exit (exit b)) :: nil). - -Theorem trans_block_noheader_inv: forall bb, trans_block (no_header bb) = trans_block bb. -Proof. - intros. destruct bb as [hd bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. -Qed. - -Theorem trans_block_header_inv: forall bb hd, trans_block (stick_header hd bb) = trans_block bb. -Proof. - intros. destruct bb as [hdr bdy ex COR]; unfold no_header; simpl. unfold trans_block. simpl. reflexivity. -Qed. - -Definition state := L.mem. -Definition exec := L.run. - -Definition match_states (s: Asmvliw.state) (s': state) := - let (rs, m) := s in - s' pmem = Memstate m - /\ forall r, s' (#r) = Val (rs r). - -Definition match_outcome (o:outcome) (s: option state) := - match o with - | Next rs m => exists s', s=Some s' /\ match_states (State rs m) s' - | Stuck => s=None - end. - -Notation "a <[ b <- c ]>" := (assign a b c) (at level 102, right associativity). - -Definition trans_state (s: Asmvliw.state) : state := - let (rs, m) := s in - fun x => if (Pos.eq_dec x pmem) then Memstate m - else match (inv_ppos x) with - | Some r => Val (rs r) - | None => Val Vundef - end. - -Lemma not_eq_IR: - forall r r', r <> r' -> IR r <> IR r'. -Proof. - intros. congruence. -Qed. - -(** Parallelizability test of a bblock (bundle), and bisimulation of the Asmblock and L parallel semantics *) - -Module PChk := ParallelChecks L PosPseudoRegSet. - -Definition bblock_para_check (p: Asmvliw.bblock) : bool := - PChk.is_parallelizable (trans_block p). - -Section SECT_PAR. - -Import PChk. - -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - || (rewrite assign_diff by (auto; try discriminate; try (apply ppos_discr; try discriminate; congruence); try (apply ppos_pmem_discr); - try (apply not_eq_sym; apply ppos_discr; try discriminate; congruence); try (apply not_eq_sym; apply ppos_pmem_discr); auto)) - || (rewrite assign_eq) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -Arguments Pos.add: simpl never. -Arguments ppos: simpl never. - -Variable Ge: genv. - -Lemma trans_arith_par_correct ge fn rsr mr sr rsw mw sw rsw' i: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - parexec_arith_instr ge i rsr rsw = rsw' -> - exists sw', - inst_prun Ge (trans_arith i) sw sr sr = Some sw' - /\ match_states (State rsw' mw) sw'. -Proof. - intros GENV MSR MSW PARARITH. subst. inv MSR. inv MSW. - unfold parexec_arith_instr. destruct i. -(* Ploadsymbol *) - - destruct i. eexists; split; [| split]. - * simpl. reflexivity. - * Simpl. - * simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRR *) - - eexists; split; [| split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRI32 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRI64 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRF32 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRF64 *) - - eexists; split; [|split]. - * simpl. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRR *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRI32 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithRRI64 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRR *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs1). rewrite (H0 rs2). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARR *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRI32 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* PArithARRI64 *) - - eexists; split; [|split]. - * simpl. rewrite (H0 rd). rewrite (H0 rs). reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -Qed. - - - -Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (bstep ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr). -Proof. - -(* a little tactic to automate reasoning on preg_eq *) -Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. -Local Ltac preg_eq_discr r rd := - destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto); - rewrite (assign_diff _ (#rd) (#r) _); auto; - rewrite Pregmap.gso; auto. - - intros GENV MSR MSW; inversion MSR as (H & H0); inversion MSW as (H1 & H2). - destruct bi; simpl. -(* Arith *) - - exploit trans_arith_par_correct. 5: eauto. all: eauto. -(* Load *) - - destruct i. - (* Load Offset *) - + destruct i; simpl load_chunk. all: - unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0; - unfold eval_offset; - simpl; auto; - destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - - (* Load Reg *) - + destruct i; simpl load_chunk. all: - unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - - (* Load Reg XS *) - + destruct i; simpl load_chunk. all: - unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs); - destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl. - - (* Load Quad word *) - + unfold parexec_load_q_offset. - destruct (gpreg_q_expand rd) as [rd0 rd1]; destruct Ge; simpl. - rewrite H0, H. - destruct (Mem.loadv Many64 mr _) as [load0 | ]; simpl; auto. - rewrite !(assign_diff _ _ pmem), H; auto. - destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. - eexists; intuition eauto. - { rewrite !(assign_diff _ _ pmem); auto. } - { preg_eq_discr r rd1. - preg_eq_discr r rd0. } - - (* Load Octuple word *) - + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core. - unfold parexec_load_o_offset. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl. - rewrite H0, H. - destruct (Mem.loadv Many64 mr (Val.offset_ptr (rsr ra) ofs)) as [load0 | ]; simpl; auto. - rewrite !(assign_diff _ _ pmem), !H; auto. - destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 8)))) as [load1| ]; simpl; auto. - rewrite !(assign_diff _ _ pmem), !H; auto. - destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 16)))) as [load2| ]; simpl; auto. - rewrite !(assign_diff _ _ pmem), !H; auto. - destruct (Mem.loadv Many64 mr (_ _ (Ptrofs.add ofs (Ptrofs.repr 24)))) as [load3| ]; simpl; auto. - eexists; intuition eauto. - { rewrite !(assign_diff _ _ pmem); auto. } - { preg_eq_discr r rd3. - preg_eq_discr r rd2. - preg_eq_discr r rd1. - preg_eq_discr r rd0. } - -(* Store *) - - destruct i. - (* Store Offset *) - + destruct i; simpl store_chunk. all: - unfold parexec_store_offset; simpl; unfold exec_store_deps_offset; erewrite GENV, H, H0; rewrite (H0 ra); - unfold eval_offset; simpl; auto; - destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl. - - (* Store Reg *) - + destruct i; simpl store_chunk. all: - unfold parexec_store_reg; simpl; unfold exec_store_deps_reg; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); - destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl. - - (* Store Reg XS *) - + destruct i; simpl store_chunk. all: - unfold parexec_store_regxs; simpl; unfold exec_store_deps_regxs; rewrite H, H0; rewrite (H0 ra); rewrite (H0 rofs); - destruct (Mem.storev _ _ _ _) eqn:MEML; simpl; auto; - eexists; split; try split; Simpl; - intros rr; destruct rr; Simpl. - - (* Store Quad Word *) - + unfold parexec_store_q_offset. - destruct (gpreg_q_expand rs) as [s0 s1]; destruct Ge; simpl. - rewrite !H0, !H. - destruct (Mem.storev _ _ _ (rsr s0)) as [mem0 | ]; simpl; auto. - rewrite !assign_diff, !H0; auto. - destruct (Mem.storev _ _ _ (rsr s1)) as [mem1 | ]; simpl; auto. - eexists; intuition eauto. - rewrite !assign_diff; auto. - - (* Store Ocuple Word *) - + unfold parexec_store_o_offset. - destruct (gpreg_o_expand rs) as [[[s0 s1] s2] s3]; destruct Ge; simpl. - rewrite !H0, !H. - destruct (Mem.storev _ _ _ (rsr s0)) as [store0 | ]; simpl; auto. - rewrite !assign_diff, !H0; auto. - destruct (Mem.storev _ _ _ (rsr s1)) as [store1 | ]; simpl; auto. - rewrite !assign_diff, !H0; auto. - destruct (Mem.storev _ _ _ (rsr s2)) as [store2 | ]; simpl; auto. - rewrite !assign_diff, !H0; auto. - destruct (Mem.storev _ _ _ (rsr s3)) as [store3 | ]; simpl; auto. - eexists; intuition eauto. - rewrite !assign_diff; auto. - - (* Allocframe *) - - destruct (Mem.alloc _ _ _) eqn:MEMAL. destruct (Mem.store _ _ _ _) eqn:MEMS. - * eexists; repeat split. - { Simpl. erewrite !H0, H, MEMAL, MEMS. Simpl. - rewrite H, MEMAL. rewrite MEMS. reflexivity. } - { Simpl. } - { intros rr; destruct rr; Simpl. - destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. } - * simpl; Simpl; erewrite !H0, H, MEMAL, MEMS; auto. - (* Freeframe *) - - erewrite !H0, H. - destruct (Mem.loadv _ _ _) eqn:MLOAD; simpl; auto. - destruct (rsr GPR12) eqn:SPeq; simpl; auto. - destruct (Mem.free _ _ _ _) eqn:MFREE; simpl; auto. - eexists; repeat split. - * simpl. Simpl. erewrite H0, SPeq, MLOAD, MFREE. reflexivity. - * Simpl. - * intros rr; destruct rr; Simpl. destruct (ireg_eq g GPR32); [| destruct (ireg_eq g GPR12); [| destruct (ireg_eq g GPR17)]]; subst; Simpl. -(* Pget *) - - destruct rs eqn:rseq; simpl; auto. - eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. - destruct (ireg_eq g rd); subst; Simpl. -(* Pset *) - - destruct rd eqn:rdeq; simpl; auto. - eexists. repeat split. Simpl. intros rr; destruct rr; Simpl. -(* Pnop *) - - eexists. repeat split; assumption. -Qed. - - -Theorem bisimu_par_body: - forall bdy ge fn rsr mr sr rsw mw sw, - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (parexec_wio_body ge bdy rsr rsw mr mw) (prun_iw Ge (trans_body bdy) sw sr). -Proof. - induction bdy as [|i bdy]; simpl; eauto. - intros. - exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto. - destruct (bstep _ _ _ _ _ _); simpl. - - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - - intros X; rewrite X; simpl; auto. -Qed. - -Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) (rsw#PC <- aux) mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). -Proof. - intros GENV MSR MSW; unfold estep. - simpl in *. inv MSR. inv MSW. - destruct ex. - - destruct c; destruct i; try discriminate; simpl. - all: try (rewrite (H0 PC); eexists; split; try split; Simpl; intros rr; destruct rr; unfold incrPC; Simpl). - - (* Pjumptable *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). unfold incrPC. Simpl. - destruct (rsr r); simpl; auto. destruct (list_nth_z _ _); simpl; auto. - unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. - destruct (preg_eq g GPR62). rewrite e. Simpl. - destruct (preg_eq g GPR63). rewrite e. Simpl. Simpl. - - (* Pj_l *) - + rewrite (H0 PC). Simpl. unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. - unfold incrPC. Simpl. destruct (Val.offset_ptr _ _); simpl; auto. - eexists; split; try split; Simpl. intros rr; destruct rr; unfold incrPC; Simpl. - - (* Pcb *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmp_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. - ++ destruct (Val.cmp_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - ++ destruct (Val.cmpl_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - - (* Pcbu *) - + rewrite (H0 PC). Simpl. rewrite (H0 r). destruct (cmpu_for_btest _); simpl; auto. destruct o; simpl; auto. - unfold par_eval_branch. unfold eval_branch_deps. unfold incrPC. Simpl. destruct i. - ++ destruct (Val_cmpu_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - ++ destruct (Val_cmplu_bool _ _ _); simpl; auto. destruct b. - +++ unfold par_goto_label. unfold goto_label_deps. destruct (label_pos _ _ _); simpl; auto. Simpl. - destruct (Val.offset_ptr _ _); simpl; auto. eexists; split; try split; Simpl. - intros rr; destruct rr; Simpl. - +++ repeat (econstructor; eauto). intros rr; destruct rr; Simpl. - - - simpl in *. rewrite (H0 PC). eexists; split; try split; Simpl. - intros rr; destruct rr; unfold incrPC; Simpl. -Qed. - -Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_states (State rsw mw) sw -> - match_outcome (estep ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr). -Proof. - intros; unfold estep. - exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto. - cutrewrite (rsw # PC <- (rsw PC) = rsw); auto. - apply extensionality. intros; destruct x; simpl; auto. -Qed. - -Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil). - -Theorem bisimu_par_wio ge fn rsr mr sr bdy ex sz: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr). -Proof. - intros GENV MSR. unfold parexec_wio, trans_block_aux. - exploit (bisimu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto. - destruct (parexec_wio_body _ _ _ _ _ _); simpl. - - intros (s' & X1 & X2). - erewrite prun_iw_app_Some; eauto. - exploit (bisimu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto. - subst Ge; simpl. destruct MSR as (Y1 & Y2). erewrite Y2; simpl. - destruct (inst_prun _ _ _ _ _); simpl; auto. - - intros X; erewrite prun_iw_app_None; eauto. -Qed. - -Theorem bisimu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz: - Ge = Genv ge fn -> - match_states (State rsr mr) sr -> - match_outcome - match parexec_wio ge fn bdy1 ex (Ptrofs.repr sz) rsr mr with - | Next rs' m' => parexec_wio_body ge bdy2 rsr rs' mr m' - | Stuck => Stuck - end - (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr). -Proof. - intros. - exploit (bisimu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto. - destruct (parexec_wio _ _ _ _ _ _); simpl. - - intros (s' & X1 & X2). - erewrite prun_iw_app_Some; eauto. - eapply bisimu_par_body; eauto. - - intros; erewrite prun_iw_app_None; eauto. -Qed. - -Lemma trans_body_perserves_permutation bdy1 bdy2: - Permutation bdy1 bdy2 -> - Permutation (trans_body bdy1) (trans_body bdy2). -Proof. - induction 1; simpl; econstructor; eauto. -Qed. - -Lemma trans_body_app bdy1: forall bdy2, - trans_body (bdy1++bdy2) = (trans_body bdy1) ++ (trans_body bdy2). -Proof. - induction bdy1; simpl; congruence. -Qed. - -Theorem trans_block_perserves_permutation bdy1 bdy2 b: - Permutation (bdy1 ++ bdy2) (body b) -> - Permutation (trans_block b) ((trans_block_aux bdy1 (size b) (exit b))++(trans_body bdy2)). -Proof. - intro H; unfold trans_block, trans_block_aux. - eapply perm_trans. - - eapply Permutation_app_tail. - apply trans_body_perserves_permutation. - apply Permutation_sym; eapply H. - - rewrite trans_body_app. rewrite <-! app_assoc. - apply Permutation_app_head. - apply Permutation_app_comm. -Qed. - -Theorem bisimu_par rs1 m1 s1' b ge fn o2: - Ge = Genv ge fn -> - match_states (State rs1 m1) s1' -> - parexec_bblock ge fn b rs1 m1 o2 -> - exists o2', - prun Ge (trans_block b) s1' o2' - /\ match_outcome o2 o2'. -Proof. - intros GENV MS PAREXEC. - inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO). - exploit trans_block_perserves_permutation; eauto. - intros Perm. - exploit (bisimu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto. - rewrite <- WIO. clear WIO. - intros H; eexists; split. 2: eapply H. - unfold prun; eexists; split; eauto. - destruct (prun_iw _ _ _ _); simpl; eauto. -Qed. - -(** sequential execution *) -Theorem bisimu_basic ge fn bi rs m s: - Ge = Genv ge fn -> - match_states (State rs m) s -> - match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s). -Proof. - intros; unfold exec_basic_instr. rewrite inst_run_prun. - eapply bisimu_par_wio_basic; eauto. -Qed. - -Lemma bisimu_body: - forall bdy ge fn rs m s, - Ge = Genv ge fn -> - match_states (State rs m) s -> - match_outcome (exec_body ge bdy rs m) (exec Ge (trans_body bdy) s). -Proof. - induction bdy as [|i bdy]; simpl; eauto. - intros. - exploit (bisimu_basic ge fn i rs m s); eauto. - destruct (exec_basic_instr _ _ _ _); simpl. - - intros (s' & X1 & X2). rewrite X1; simpl; eauto. - - intros X; rewrite X; simpl; auto. -Qed. - -Theorem bisimu_exit ge fn b rs m s: - Ge = Genv ge fn -> - match_states (State rs m) s -> - match_outcome (exec_control ge fn (exit b) (nextblock b rs) m) (inst_run Ge (trans_pcincr (size b) (trans_exit (exit b))) s s). -Proof. - intros; unfold exec_control, nextblock. rewrite inst_run_prun. - apply (bisimu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto. -Qed. - -Theorem bisimu rs m b ge fn s: - Ge = Genv ge fn -> - match_states (State rs m) s -> - match_outcome (exec_bblock ge fn b rs m) (exec Ge (trans_block b) s). -Proof. - intros GENV MS. unfold exec_bblock. - exploit (bisimu_body (body b) ge fn rs m s); eauto. - unfold exec, trans_block; simpl. - destruct (exec_body _ _ _ _); simpl. - - intros (s' & X1 & X2). - erewrite run_app_Some; eauto. - exploit (bisimu_exit ge fn b rs0 m0 s'); eauto. - subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl. - destruct (inst_run _ _ _); simpl; auto. - - intros X; erewrite run_app_None; eauto. -Qed. - - -Theorem trans_state_match: forall S, match_states S (trans_state S). -Proof. - intros. destruct S as (rs & m). simpl. - split. reflexivity. - intro. destruct r; try reflexivity. - destruct g; reflexivity. -Qed. - - -Lemma state_eq_decomp: - forall rs1 m1 rs2 m2, rs1 = rs2 -> m1 = m2 -> State rs1 m1 = State rs2 m2. -Proof. - intros. congruence. -Qed. - -Theorem state_equiv S1 S2 S': match_states S1 S' -> match_states S2 S' -> S1 = S2. -Proof. - unfold match_states; intros H0 H1. destruct S1 as (rs1 & m1). destruct S2 as (rs2 & m2). inv H0. inv H1. - apply state_eq_decomp. - - apply functional_extensionality. intros. assert (Val (rs1 x) = Val (rs2 x)) by congruence. congruence. - - congruence. -Qed. - -Lemma bblock_para_check_correct ge fn bb rs m rs' m': - Ge = Genv ge fn -> - exec_bblock ge fn bb rs m = Next rs' m' -> - bblock_para_check bb = true -> - det_parexec ge fn bb rs m rs' m'. -Proof. - intros H H0 H1 o H2. unfold bblock_para_check in H1. - exploit (bisimu rs m bb ge fn); eauto. eapply trans_state_match. - rewrite H0; simpl. - intros (s2' & EXEC & MS). - exploit bisimu_par. 2: apply (trans_state_match (State rs m)). all: eauto. - intros (o2' & PRUN & MO). - exploit parallelizable_correct. apply is_para_correct_aux. eassumption. - intro. eapply H3 in PRUN. clear H3. destruct o2'. - - inv PRUN. inv H3. unfold exec in EXEC; unfold trans_state in H. - assert (x = s2') by congruence. subst. clear H. - assert (m0 = s2') by (apply functional_extensionality; auto). subst. clear H4. - destruct o; try discriminate. inv MO. inv H. assert (s2' = x) by congruence. subst. - exploit (state_equiv (State rs' m') (State rs0 m0)). - 2: eapply H4. eapply MS. intro H. inv H. reflexivity. - - unfold match_outcome in MO. destruct o. - + inv MO. inv H3. discriminate. - + clear MO. unfold exec in EXEC. - unfold trans_state in PRUN; rewrite EXEC in PRUN. discriminate. -Qed. - -End SECT_PAR. - -Section SECT_BBLOCK_EQUIV. - -Variable Ge: genv. - -Local Hint Resolve trans_state_match: core. - -Lemma bblock_simu_reduce: - forall p1 p2 ge fn, - Ge = Genv ge fn -> - L.bblock_simu Ge (trans_block p1) (trans_block p2) -> - Asmblockprops.bblock_simu ge fn p1 p2. -Proof. - unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK. - generalize (H2 (trans_state (State rs m))); clear H2. - intro H2. - exploit (bisimu Ge rs m p1 ge fn (trans_state (State rs m))); eauto. - exploit (bisimu Ge rs m p2 ge fn (trans_state (State rs m))); eauto. - destruct (exec_bblock ge fn p1 rs m); try congruence. - intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2. - destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3. - destruct (exec_bblock ge fn p2 rs m); simpl in H3. - * destruct H3 as (s' & H3 & H5 & H6). inv H3. inv MS'. - cutrewrite (rs0=rs1). - - cutrewrite (m0=m1); auto. congruence. - - apply functional_extensionality. intros r. - generalize (H0 r). intros Hr. congruence. - * discriminate. -Qed. - -(** Used for debug traces *) - -Definition gpreg_name (gpr: gpreg) := - match gpr with - | GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4") - | GPR5 => Str ("GPR5") | GPR6 => Str ("GPR6") | GPR7 => Str ("GPR7") | GPR8 => Str ("GPR8") | GPR9 => Str ("GPR9") - | GPR10 => Str ("GPR10") | GPR11 => Str ("GPR11") | GPR12 => Str ("GPR12") | GPR13 => Str ("GPR13") | GPR14 => Str ("GPR14") - | GPR15 => Str ("GPR15") | GPR16 => Str ("GPR16") | GPR17 => Str ("GPR17") | GPR18 => Str ("GPR18") | GPR19 => Str ("GPR19") - | GPR20 => Str ("GPR20") | GPR21 => Str ("GPR21") | GPR22 => Str ("GPR22") | GPR23 => Str ("GPR23") | GPR24 => Str ("GPR24") - | GPR25 => Str ("GPR25") | GPR26 => Str ("GPR26") | GPR27 => Str ("GPR27") | GPR28 => Str ("GPR28") | GPR29 => Str ("GPR29") - | GPR30 => Str ("GPR30") | GPR31 => Str ("GPR31") | GPR32 => Str ("GPR32") | GPR33 => Str ("GPR33") | GPR34 => Str ("GPR34") - | GPR35 => Str ("GPR35") | GPR36 => Str ("GPR36") | GPR37 => Str ("GPR37") | GPR38 => Str ("GPR38") | GPR39 => Str ("GPR39") - | GPR40 => Str ("GPR40") | GPR41 => Str ("GPR41") | GPR42 => Str ("GPR42") | GPR43 => Str ("GPR43") | GPR44 => Str ("GPR44") - | GPR45 => Str ("GPR45") | GPR46 => Str ("GPR46") | GPR47 => Str ("GPR47") | GPR48 => Str ("GPR48") | GPR49 => Str ("GPR49") - | GPR50 => Str ("GPR50") | GPR51 => Str ("GPR51") | GPR52 => Str ("GPR52") | GPR53 => Str ("GPR53") | GPR54 => Str ("GPR54") - | GPR55 => Str ("GPR55") | GPR56 => Str ("GPR56") | GPR57 => Str ("GPR57") | GPR58 => Str ("GPR58") | GPR59 => Str ("GPR59") - | GPR60 => Str ("GPR60") | GPR61 => Str ("GPR61") | GPR62 => Str ("GPR62") | GPR63 => Str ("GPR63") - end. - -Definition string_of_name (x: P.R.t): ?? pstring := - if (Pos.eqb x pmem) then - RET (Str "MEM") - else - match inv_ppos x with - | Some RA => RET (Str ("RA")) - | Some PC => RET (Str ("PC")) - | Some (IR gpr) => RET (gpreg_name gpr) - | _ => RET (Str ("UNDEFINED")) - end. - -Definition string_of_name_r (n: arith_name_r): pstring := - match n with - | Ploadsymbol _ _ => "Ploadsymbol" - end. - -Definition string_of_name_rr (n: arith_name_rr): pstring := - match n with - Pmv => "Pmv" - | Pnegw => "Pnegw" - | Pnegl => "Pnegl" - | Pcvtl2w => "Pcvtl2w" - | Psxwd => "Psxwd" - | Pzxwd => "Pzxwd" - | Pextfz _ _ => "Pextfz" - | Pextfs _ _ => "Pextfs" - | Pextfzl _ _ => "Pextfzl" - | Pextfsl _ _ => "Pextfsl" - | Pfabsd => "Pfabsd" - | Pfabsw => "Pfabsw" - | Pfnegd => "Pfnegd" - | Pfnegw => "Pfnegw" - | Pfinvw => "Pfinvw" - | Pfnarrowdw => "Pfnarrowdw" - | Pfwidenlwd => "Pfwidenlwd" - | Pfloatwrnsz => "Pfloatwrnsz" - | Pfloatuwrnsz => "Pfloatuwrnsz" - | Pfloatudrnsz => "Pfloatudrnsz" - | Pfloatdrnsz => "Pfloatdrnsz" - | Pfixedwrzz => "Pfixedwrzz" - | Pfixeduwrzz => "Pfixeduwrzz" - | Pfixeddrzz => "Pfixeddrzz" - | Pfixedudrzz => "Pfixedudrzz" - | Pfixeddrzz_i32 => "Pfixeddrzz_i32" - | Pfixedudrzz_i32 => "Pfixedudrzz_i32" - end. - -Definition string_of_name_ri32 (n: arith_name_ri32): pstring := - match n with - | Pmake => "Pmake" - end. - -Definition string_of_name_ri64 (n: arith_name_ri64): pstring := - match n with - | Pmakel => "Pmakel" - end. - -Definition string_of_name_rf32 (n: arith_name_rf32): pstring := - match n with - | Pmakefs => "Pmakefs" - end. - -Definition string_of_name_rf64 (n: arith_name_rf64): pstring := - match n with - | Pmakef => "Pmakef" - end. - -Definition string_of_name_rrr (n: arith_name_rrr): pstring := - match n with - | Pcompw _ => "Pcompw" - | Pcompl _ => "Pcompl" - | Pfcompw _ => "Pfcompw" - | Pfcompl _ => "Pfcompl" - | Paddw => "Paddw" - | Paddxw _ => "Paddxw" - | Psubw => "Psubw" - | Prevsubxw _ => "Prevsubxw" - | Pmulw => "Pmulw" - | Pandw => "Pandw" - | Pnandw => "Pnandw" - | Porw => "Porw" - | Pnorw => "Pnorw" - | Pxorw => "Pxorw" - | Pnxorw => "Pnxorw" - | Pandnw => "Pandnw" - | Pornw => "Pornw" - | Psraw => "Psraw" - | Psrlw => "Psrlw" - | Psrxw => "Psrxw" - | Psllw => "Psllw" - | Paddl => "Paddl" - | Paddxl _ => "Paddxl" - | Psubl => "Psubl" - | Prevsubxl _ => "Prevsubxl" - | Pandl => "Pandl" - | Pnandl => "Pnandl" - | Porl => "Porl" - | Pnorl => "Pnorl" - | Pxorl => "Pxorl" - | Pnxorl => "Pnxorl" - | Pandnl => "Pandnl" - | Pornl => "Pornl" - | Pmull => "Pmull" - | Pslll => "Pslll" - | Psrll => "Psrll" - | Psrxl => "Psrxl" - | Psral => "Psral" - | Pfaddd => "Pfaddd" - | Pfaddw => "Pfaddw" - | Pfsbfd => "Pfsbfd" - | Pfsbfw => "Pfsbfw" - | Pfmuld => "Pfmuld" - | Pfmulw => "Pfmulw" - | Pfmind => "Pfmind" - | Pfminw => "Pfminw" - | Pfmaxd => "Pfmaxd" - | Pfmaxw => "Pfmaxw" - end. - -Definition string_of_name_rri32 (n: arith_name_rri32): pstring := - match n with - Pcompiw _ => "Pcompiw" - | Paddiw => "Paddiw" - | Paddxiw _ => "Paddxiw" - | Prevsubiw => "Prevsubiw" - | Prevsubxiw _ => "Prevsubxiw" - | Pmuliw => "Pmuliw" - | Pandiw => "Pandiw" - | Pnandiw => "Pnandiw" - | Poriw => "Poriw" - | Pnoriw => "Pnoriw" - | Pxoriw => "Pxoriw" - | Pnxoriw => "Pnxoriw" - | Pandniw => "Pandniw" - | Porniw => "Porniw" - | Psraiw => "Psraiw" - | Psrliw => "Psrliw" - | Psrxiw => "Psrxiw" - | Pslliw => "Pslliw" - | Proriw => "Proriw" - | Psllil => "Psllil" - | Psrlil => "Psrlil" - | Psrail => "Psrail" - | Psrxil => "Psrxil" - end. - -Definition string_of_name_rri64 (n: arith_name_rri64): pstring := - match n with - Pcompil _ => "Pcompil" - | Paddil => "Paddil" - | Prevsubil => "Prevsubil" - | Paddxil _ => "Paddxil" - | Prevsubxil _ => "Prevsubxil" - | Pmulil => "Pmulil" - | Pandil => "Pandil" - | Pnandil => "Pnandil" - | Poril => "Poril" - | Pnoril => "Pnoril" - | Pxoril => "Pxoril" - | Pnxoril => "Pnxoril" - | Pandnil => "Pandnil" - | Pornil => "Pornil" - end. - -Definition string_of_name_arrr (n: arith_name_arrr): pstring := - match n with - | Pmaddw => "Pmaddw" - | Pmaddl => "Pmaddl" - | Pmsubw => "Pmsubw" - | Pmsubl => "Pmsubl" - | Pcmove _ => "Pcmove" - | Pcmoveu _ => "Pcmoveu" - | Pfmaddfw => "Pfmaddfw" - | Pfmaddfl => "Pfmaddfl" - | Pfmsubfw => "Pfmsubfw" - | Pfmsubfl => "Pfmsubfl" - end. - -Definition string_of_name_arr (n: arith_name_arr): pstring := - match n with - | Pinsf _ _ => "Pinsf" - | Pinsfl _ _ => "Pinsfl" - end. - -Definition string_of_name_arri32 (n: arith_name_arri32): pstring := - match n with - | Pmaddiw => "Pmaddw" - | Pcmoveiw _ => "Pcmoveiw" - | Pcmoveuiw _ => "Pcmoveuiw" - end. - -Definition string_of_name_arri64 (n: arith_name_arri64): pstring := - match n with - | Pmaddil => "Pmaddl" - | Pcmoveil _ => "Pcmoveil" - | Pcmoveuil _ => "Pcmoveuil" - end. - -Definition string_of_arith (op: arith_op): pstring := - match op with - | OArithR n => string_of_name_r n - | OArithRR n => string_of_name_rr n - | OArithRI32 n _ => string_of_name_ri32 n - | OArithRI64 n _ => string_of_name_ri64 n - | OArithRF32 n _ => string_of_name_rf32 n - | OArithRF64 n _ => string_of_name_rf64 n - | OArithRRR n => string_of_name_rrr n - | OArithRRI32 n _ => string_of_name_rri32 n - | OArithRRI64 n _ => string_of_name_rri64 n - | OArithARRR n => string_of_name_arrr n - | OArithARR n => string_of_name_arr n - | OArithARRI32 n _ => string_of_name_arri32 n - | OArithARRI64 n _ => string_of_name_arri64 n - end. - -Definition string_of_load_name (n: load_name) : pstring := - match n with - Plb => "Plb" - | Plbu => "Plbu" - | Plh => "Plh" - | Plhu => "Plhu" - | Plw => "Plw" - | Plw_a => "Plw_a" - | Pld => "Pld" - | Pld_a => "Pld_a" - | Pfls => "Pfls" - | Pfld => "Pfld" - end. - -Definition string_of_load (op: load_op): pstring := - match op with - | OLoadRRO n _ _ => string_of_load_name n - | OLoadRRR n _ => string_of_load_name n - | OLoadRRRXS n _ => string_of_load_name n - end. - -Definition string_of_store_name (n: store_name) : pstring := - match n with - Psb => "Psb" - | Psh => "Psh" - | Psw => "Psw" - | Psw_a => "Psw_a" - | Psd => "Psd" - | Psd_a => "Psd_a" - | Pfss => "Pfss" - | Pfsd => "Pfsd" - end. - -Definition string_of_store (op: store_op) : pstring := - match op with - | OStoreRRO n _ => string_of_store_name n - | OStoreRRR n => string_of_store_name n - | OStoreRRRXS n => string_of_store_name n - end. - -Definition string_of_control (op: control_op) : pstring := - match op with - | Oj_l _ => "Oj_l" - | Ocb _ _ => "Ocb" - | Ocbu _ _ => "Ocbu" - | Odiv => "Odiv" - | Odivu => "Odivu" - | Ojumptable _ => "Ojumptable" - | OError => "OError" - | OIncremPC _ => "OIncremPC" - end. - -Definition string_of_op (op: P.op): ?? pstring := - match op with - | Arith op => RET (string_of_arith op) - | Load op => RET (string_of_load op) - | Store op => RET (string_of_store op) - | Control op => RET (string_of_control op) - | Allocframe _ _ => RET (Str "Allocframe") - | Allocframe2 _ _ => RET (Str "Allocframe2") - | Freeframe _ _ => RET (Str "Freeframe") - | Freeframe2 _ _ => RET (Str "Freeframe2") - | Constant _ => RET (Str "Constant") - | Fail => RET (Str "Fail") - end. - -End SECT_BBLOCK_EQUIV. - -(** REWRITE RULES *) - -Definition is_constant (o: op): bool := - match o with - | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true - | _ => false - end. - -Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None. -Proof. - destruct o; simpl in * |- *; try congruence. - destruct ao; simpl in * |- *; try congruence; - destruct n; simpl in * |- *; try congruence; - unfold arith_eval; destruct ge; simpl in * |- *; try congruence. -Qed. - -Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t). - -Local Hint Resolve is_constant_correct: wlp. - -Lemma main_reduce_correct t: - WHEN main_reduce t ~> pt THEN Terms.match_pt t pt. -Proof. - wlp_simplify. -Qed. - -Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}. - -Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool := - if verb then - IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2) - else - IST.bblock_simu_test reduce (trans_block p1) (trans_block p2). - -Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp. - -Theorem bblock_simu_test_correct verb p1 p2 : - WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2. -Proof. - wlp_simplify. -Qed. -Hint Resolve bblock_simu_test_correct: wlp. - -(* Coerce bblock_simu_test into a pure function (this is a little unsafe like all oracles in CompCert). *) - -Import UnsafeImpure. - -Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := - match unsafe_coerce (bblock_simu_test verb p1 p2) with - | Some b => b - | None => false - end. - -Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. -Proof. - unfold pure_bblock_simu_test. - destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate. - intros; subst. eapply bblock_simu_test_correct; eauto. - apply unsafe_coerce_not_really_correct; eauto. -Qed. - -Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true. - -Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2. -Proof. - eapply (pure_bblock_simu_test_correct true). -Qed. diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v deleted file mode 100644 index f57b596b..00000000 --- a/mppa_k1c/Asmblockgen.v +++ /dev/null @@ -1,1217 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** * Translation from Machblock to K1c assembly language (Asmblock) - Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *) - -Require Archi. -Require Import Coqlib Errors. -Require Import AST Integers Floats Memdata. -Require Import Op Locations Machblock Asmblock. -Require ExtValues. -Require Import Chunks. - -Local Open Scope string_scope. -Local Open Scope error_monad_scope. - -Import PArithCoercions. - -(** The code generation functions take advantage of several - characteristics of the [Mach] code generated by earlier passes of the - compiler, mostly that argument and result registers are of the correct - types. These properties are true by construction, but it's easier to - recheck them during code generation and fail if they do not hold. *) - -(** Extracting integer or float registers. *) - -Definition ireg_of (r: mreg) : res ireg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.ireg_of") end. - -Definition freg_of (r: mreg) : res freg := - match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end. - -Inductive immed32 : Type := - | Imm32_single (imm: int). - -Definition make_immed32 (val: int) := Imm32_single val. - -Inductive immed64 : Type := - | Imm64_single (imm: int64) -. - -Definition make_immed64 (val: int64) := Imm64_single val. - -Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity). -Notation "a ::i b" := (cons (A:=basic) a b) (at level 49, right associativity). -Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associativity). -Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity). -Notation "a @@ b" := (app a b) (at level 49, right associativity). - -Definition loadimm32 (r: ireg) (n: int) := - match make_immed32 n with - | Imm32_single imm => Pmake r imm - end. - -Definition opimm32 (op: arith_name_rrr) - (opimm: arith_name_rri32) - (rd rs: ireg) (n: int) := - match make_immed32 n with - | Imm32_single imm => opimm rd rs imm - end. - -Definition addimm32 := opimm32 Paddw Paddiw. -Definition mulimm32 := opimm32 Pmulw Pmuliw. -Definition andimm32 := opimm32 Pandw Pandiw. -Definition nandimm32 := opimm32 Pnandw Pnandiw. -Definition orimm32 := opimm32 Porw Poriw. -Definition norimm32 := opimm32 Pnorw Pnoriw. -Definition xorimm32 := opimm32 Pxorw Pxoriw. -Definition nxorimm32 := opimm32 Pnxorw Pnxoriw. - -Definition loadimm64 (r: ireg) (n: int64) := - match make_immed64 n with - | Imm64_single imm => Pmakel r imm - end. - -Definition opimm64 (op: arith_name_rrr) - (opimm: arith_name_rri64) - (rd rs: ireg) (n: int64) := - match make_immed64 n with - | Imm64_single imm => opimm rd rs imm -end. - -Definition addimm64 := opimm64 Paddl Paddil. -Definition mulimm64 := opimm64 Pmull Pmulil. -Definition orimm64 := opimm64 Porl Poril. -Definition andimm64 := opimm64 Pandl Pandil. -Definition xorimm64 := opimm64 Pxorl Pxoril. -Definition norimm64 := opimm64 Pnorl Pnoril. -Definition nandimm64 := opimm64 Pnandl Pnandil. -Definition nxorimm64 := opimm64 Pnxorl Pnxoril. - -Definition addptrofs (rd rs: ireg) (n: ptrofs) := - if Ptrofs.eq_dec n Ptrofs.zero then - Pmv rd rs - else - addimm64 rd rs (Ptrofs.to_int64 n). - -(** Translation of conditional branches. *) - -Definition transl_comp - (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompw (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. - -Definition transl_compi - (c: comparison) (s: signedness) (r: ireg) (imm: int) (lbl: label) (k: code) : list instruction := - Pcompiw (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. - -Definition transl_compl - (c: comparison) (s: signedness) (r1 r2: ireg) (lbl: label) (k: code) : list instruction := - Pcompl (itest_for_cmp c s) RTMP r1 r2 ::g Pcb BTwnez RTMP lbl ::g k. - -Definition transl_compil - (c: comparison) (s: signedness) (r: ireg) (imm: int64) (lbl: label) (k: code) : list instruction := - Pcompil (itest_for_cmp c s) RTMP r imm ::g Pcb BTwnez RTMP lbl ::g k. - -Definition select_comp (n: int) (c: comparison) : option comparison := - if Int.eq n Int.zero then - match c with - | Ceq => Some Ceq - | Cne => Some Cne - | _ => None - end - else - None - . - -Definition transl_opt_compuimm - (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - if Int.eq n Int.zero then - match c with - | Ceq => Pcbu BTweqz r1 lbl ::g k - | Cne => Pcbu BTwnez r1 lbl ::g k - | _ => transl_compi c Unsigned r1 n lbl k - end - else - transl_compi c Unsigned r1 n lbl k - . - -Definition select_compl (n: int64) (c: comparison) : option comparison := - if Int64.eq n Int64.zero then - match c with - | Ceq => Some Ceq - | Cne => Some Cne - | _ => None - end - else - None - . - -Definition transl_opt_compluimm - (n: int64) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction := - if Int64.eq n Int64.zero then - match c with - | Ceq => Pcbu BTdeqz r1 lbl ::g k - | Cne => Pcbu BTdnez r1 lbl ::g k - | _ => transl_compil c Unsigned r1 n lbl k - end - else - transl_compil c Unsigned r1 n lbl k - . - -Definition transl_comp_float32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := - match ftest_for_cmp cmp with - | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k - | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k - end. - -Definition transl_comp_notfloat32 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := - match notftest_for_cmp cmp with - | Normal ft => Pfcompw ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k - | Reversed ft => Pfcompw ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k - end. - -Definition transl_comp_float64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := - match ftest_for_cmp cmp with - | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k - | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k - end. - -Definition transl_comp_notfloat64 (cmp: comparison) (r1 r2: ireg) (lbl: label) (k: code) := - match notftest_for_cmp cmp with - | Normal ft => Pfcompl ft GPR32 r1 r2 ::g Pcb BTwnez GPR32 lbl ::g k - | Reversed ft => Pfcompl ft GPR32 r2 r1 ::g Pcb BTwnez GPR32 lbl ::g k - end. - -Definition transl_cbranch - (cond: condition) (args: list mreg) (lbl: label) (k: code) : res (list instruction ) := - match cond, args with - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_opt_compuimm n c r1 lbl k) - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp c Signed r1 r2 lbl k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp c Unsigned r1 r2 lbl k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int.eq n Int.zero then - Pcb (btest_for_cmpswz c) r1 lbl ::g k - else - transl_compi c Signed r1 n lbl k - ) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_opt_compluimm n c r1 lbl k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_compl c Signed r1 r2 lbl k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_compl c Unsigned r1 r2 lbl k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (if Int64.eq n Int64.zero then - Pcb (btest_for_cmpsdz c) r1 lbl ::g k - else - transl_compil c Signed r1 n lbl k - ) - | Ccompf c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp_float64 c r1 r2 lbl k) - | Cnotcompf c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp_notfloat64 c r1 r2 lbl k) - | Ccompfs c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp_float32 c r1 r2 lbl k) - | Cnotcompfs c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_comp_notfloat32 c r1 r2 lbl k) - | _, _ => - Error(msg "Asmgenblock.transl_cbranch") - end. - -(** Translation of a condition operator. The generated code sets the - [rd] target register to 0 or 1 depending on the truth value of the - condition. *) - -Definition transl_cond_int32s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - Pcompw (itest_for_cmp cmp Signed) rd r1 r2 ::i k. - -Definition transl_cond_int32u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - Pcompw (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. - -Definition transl_cond_int64s (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - Pcompl (itest_for_cmp cmp Signed) rd r1 r2 ::i k. - -Definition transl_cond_int64u (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - Pcompl (itest_for_cmp cmp Unsigned) rd r1 r2 ::i k. - -Definition transl_condimm_int32s (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := - Pcompiw (itest_for_cmp cmp Signed) rd r1 n ::i k. - -Definition transl_condimm_int32u (cmp: comparison) (rd r1: ireg) (n: int) (k: bcode) := - Pcompiw (itest_for_cmp cmp Unsigned) rd r1 n ::i k. - -Definition transl_condimm_int64s (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := - Pcompil (itest_for_cmp cmp Signed) rd r1 n ::i k. - -Definition transl_condimm_int64u (cmp: comparison) (rd r1: ireg) (n: int64) (k: bcode) := - Pcompil (itest_for_cmp cmp Unsigned) rd r1 n ::i k. - - -Definition transl_cond_float32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - match ftest_for_cmp cmp with - | Normal ft => Pfcompw ft rd r1 r2 ::i k - | Reversed ft => Pfcompw ft rd r2 r1 ::i k - end. - -Definition transl_cond_notfloat32 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - match notftest_for_cmp cmp with - | Normal ft => Pfcompw ft rd r1 r2 ::i k - | Reversed ft => Pfcompw ft rd r2 r1 ::i k - end. - -Definition transl_cond_float64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - match ftest_for_cmp cmp with - | Normal ft => Pfcompl ft rd r1 r2 ::i k - | Reversed ft => Pfcompl ft rd r2 r1 ::i k - end. - -Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode) := - match notftest_for_cmp cmp with - | Normal ft => Pfcompl ft rd r1 r2 ::i k - | Reversed ft => Pfcompl ft rd r2 r1 ::i k - end. - - -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpuwz (c: comparison) := - match c with - | Cne => OK BTwnez - | Ceq => OK BTweqz - | Clt => Error (msg "btest_for_compuwz: Clt") - | Cge => Error (msg "btest_for_compuwz: Cge") - | Cle => OK BTweqz - | Cgt => OK BTwnez - end. - -(* CoMPare Unsigned Words to Zero *) -Definition btest_for_cmpudz (c: comparison) := - match c with - | Cne => OK BTdnez - | Ceq => OK BTdeqz - | Clt => Error (msg "btest_for_compudz: Clt") - | Cge => Error (msg "btest_for_compudz: Cge") - | Cle => OK BTdeqz - | Cgt => OK BTdnez - end. - -Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) : - res basic := - if ireg_eq rd rs - then OK Pnop - else - (match cond0 with - | Ccomp0 cmp => - OK (PArith (Pcmove (btest_for_cmpswz cmp) rd rc rs)) - | Ccompu0 cmp => - do bt <- btest_for_cmpuwz cmp; - OK (PArith (Pcmoveu bt rd rc rs)) - | Ccompl0 cmp => - OK (PArith (Pcmove (btest_for_cmpsdz cmp) rd rc rs)) - | Ccomplu0 cmp => - do bt <- btest_for_cmpudz cmp; - OK (PArith (Pcmoveu bt rd rc rs)) - end). - -Definition conditional_move_imm32 (cond0 : condition0) (rc rd : ireg) (imm : int) : res basic := - match cond0 with - | Ccomp0 cmp => - OK (PArith (Pcmoveiw (btest_for_cmpswz cmp) rd rc imm)) - | Ccompu0 cmp => - do bt <- btest_for_cmpuwz cmp; - OK (PArith (Pcmoveuiw bt rd rc imm)) - | Ccompl0 cmp => - OK (PArith (Pcmoveiw (btest_for_cmpsdz cmp) rd rc imm)) - | Ccomplu0 cmp => - do bt <- btest_for_cmpudz cmp; - OK (PArith (Pcmoveuiw bt rd rc imm)) - end. - -Definition conditional_move_imm64 (cond0 : condition0) (rc rd : ireg) (imm : int64) : res basic := - match cond0 with - | Ccomp0 cmp => - OK (PArith (Pcmoveil (btest_for_cmpswz cmp) rd rc imm)) - | Ccompu0 cmp => - do bt <- btest_for_cmpuwz cmp; - OK (PArith (Pcmoveuil bt rd rc imm)) - | Ccompl0 cmp => - OK (PArith (Pcmoveil (btest_for_cmpsdz cmp) rd rc imm)) - | Ccomplu0 cmp => - do bt <- btest_for_cmpudz cmp; - OK (PArith (Pcmoveuil bt rd rc imm)) - end. - -Definition transl_cond_op - (cond: condition) (rd: ireg) (args: list mreg) (k: bcode) := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32s c rd r1 r2 k) - | Ccompu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int32u c rd r1 r2 k) - | Ccompimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32s c rd r1 n k) - | Ccompuimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int32u c rd r1 n k) - | Ccompl c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64s c rd r1 r2 k) - | Ccomplu c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_int64u c rd r1 r2 k) - | Ccomplimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64s c rd r1 n k) - | Ccompluimm c n, a1 :: nil => - do r1 <- ireg_of a1; - OK (transl_condimm_int64u c rd r1 n k) - | Ccompfs c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_float32 c rd r1 r2 k) - | Cnotcompfs c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_notfloat32 c rd r1 r2 k) - | Ccompf c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_float64 c rd r1 r2 k) - | Cnotcompf c, a1 :: a2 :: nil => - do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (transl_cond_notfloat64 c rd r1 r2 k) - | _, _ => - Error(msg "Asmblockgen.transl_cond_op") -end. - -(** 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: bcode) := - match op, args with - | Omove, a1 :: nil => - match preg_of res, preg_of a1 with - | IR r, IR a => OK (Pmv r a ::i k) - | _ , _ => Error(msg "Asmgenblock.transl_op: Omove") - end - | Ointconst n, nil => - do rd <- ireg_of res; - OK (loadimm32 rd n ::i k) - | Olongconst n, nil => - do rd <- ireg_of res; - OK (loadimm64 rd n ::i k) - | Ofloatconst f, nil => - do rd <- freg_of res; - OK (Pmakef rd f ::i k) - | Osingleconst f, nil => - do rd <- freg_of res; - OK (Pmakefs rd f ::i k) - | Oaddrsymbol s ofs, nil => - do rd <- ireg_of res; - OK (if Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero) - then Ploadsymbol s Ptrofs.zero rd ::i addptrofs rd rd ofs ::i k - else Ploadsymbol s ofs rd ::i k) - | Oaddrstack n, nil => - do rd <- ireg_of res; - OK (addptrofs rd SP n ::i k) - - | Ocast8signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 24) ::i Psraiw rd rd (Int.repr 24) ::i k) - | Ocast16signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs (Int.repr 16) ::i Psraiw rd rd (Int.repr 16) ::i k) - | Oadd, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddw rd rs1 rs2 ::i k) - | Oaddimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm32 rd rs n ::i k) - | Oaddx shift, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddxw shift rd rs1 rs2 ::i k) - | Oaddximm shift n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Paddxiw shift rd rs n ::i k) - | Oaddxl shift, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddxl shift rd rs1 rs2 ::i k) - | Oaddxlimm shift n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Paddxil shift rd rs n ::i k) - | Oneg, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pnegw rd rs ::i k) - | Osub, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psubw rd rs1 rs2 ::i k) - | Orevsubimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Prevsubiw rd rs n ::i k) - | Orevsubx shift, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Prevsubxw shift rd rs1 rs2 ::i k) - | Orevsubximm shift n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Prevsubxiw shift rd rs n ::i k) - | Omul, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmulw rd rs1 rs2 ::i k) - | Omulimm n, a1 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; - OK (mulimm32 rd rs1 n ::i k) - | Omulhs, _ => Error(msg "Asmblockgen.transl_op: Omulhs") (* Normalement pas émis *) - | Omulhu, _ => Error(msg "Asmblockgen.transl_op: Omulhu") (* Normalement pas émis *) - | Oand, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandw rd rs1 rs2 ::i k) - | Oandimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm32 rd rs n ::i k) - | Onand, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnandw rd rs1 rs2 ::i k) - | Onandimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (nandimm32 rd rs n ::i k) - | Oor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porw rd rs1 rs2 ::i k) - | Onor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnorw rd rs1 rs2 ::i k) - | Oorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm32 rd rs n ::i k) - | Onorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (norimm32 rd rs n ::i k) - | Oxor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorw rd rs1 rs2 ::i k) - | Oxorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs n ::i k) - | Onxor, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnxorw rd rs1 rs2 ::i k) - | Onxorimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (nxorimm32 rd rs n ::i k) - | Onot, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm32 rd rs Int.mone ::i k) - | Oandn, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandnw rd rs1 rs2 ::i k) - | Oandnimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pandniw rd rs n ::i k) - | Oorn, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pornw rd rs1 rs2 ::i k) - | Oornimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Porniw rd rs n ::i k) - | Oshl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psllw rd rs1 rs2 ::i k) - | Oshlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pslliw rd rs n ::i k) - | Oshr, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psraw rd rs1 rs2 ::i k) - | Oshrimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psraiw rd rs n ::i k) - | Oshru, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrlw rd rs1 rs2 ::i k) - | Oshruimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrliw rd rs n ::i k) - | Oshrximm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrxiw rd rs n ::i k) - | Ororimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Proriw rd rs n ::i k) - | Omadd, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - do r3 <- ireg_of a3; - OK (Pmaddw r1 r2 r3 ::i k) - | Omaddimm n, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - OK (Pmaddiw r1 r2 n ::i k) - | Omsub, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - do r3 <- ireg_of a3; - OK (Pmsubw r1 r2 r3 ::i k) - (* [Omakelong], [Ohighlong] should not occur *) - | Olowlong, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pcvtl2w rd rs ::i k) - | Ocast32signed, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psxwd rd rs ::i k) - | Ocast32unsigned, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pzxwd rd rs ::i k) -(* assertion (ireg_eq rd rs); - OK (Pcvtw2l rd ::i Psllil rd rd (Int.repr 32) ::i Psrlil rd rd (Int.repr 32) ::i k) *) - | Oaddl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Paddl rd rs1 rs2 ::i k) - | Oaddlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (addimm64 rd rs n ::i k) - | Onegl, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pnegl rd rs ::i k) - | Osubl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psubl rd rs1 rs2 ::i k) - | Orevsubxl shift, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Prevsubxl shift rd rs1 rs2 ::i k) - | Orevsublimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Prevsubil rd rs n ::i k) - | Orevsubxlimm shift n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Prevsubxil shift rd rs n ::i k) - | Omull, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pmull rd rs1 rs2 ::i k) - | Omullimm n, a1 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; - OK (mulimm64 rd rs1 n ::i k) - | Omullhs, _ => Error (msg "Asmblockgen.transl_op: Omullhs") (* Normalement pas émis *) - | Omullhu, _ => Error (msg "Asmblockgen.transl_op: Omullhu") (* Normalement pas émis *) - | Odivl, _ => Error (msg "Asmblockgen.transl_op: Odivl") (* Géré par fonction externe *) - | Odivlu, _ => Error (msg "Asmblockgen.transl_op: Odivlu") (* Géré par fonction externe *) - | Omodl, _ => Error (msg "Asmblockgen.transl_op: Omodl") (* Géré par fonction externe *) - | Omodlu, _ => Error (msg "Asmblockgen.transl_op: Omodlu") (* Géré par fonction externe *) - | Onotl, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs Int64.mone ::i k) - | Oandl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandl rd rs1 rs2 ::i k) - | Oandlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (andimm64 rd rs n ::i k) - | Onandl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnandl rd rs1 rs2 ::i k) - | Onandlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (nandimm64 rd rs n ::i k) - | Oorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Porl rd rs1 rs2 ::i k) - | Oorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (orimm64 rd rs n ::i k) - | Onorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnorl rd rs1 rs2 ::i k) - | Onorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (norimm64 rd rs n ::i k) - | Oxorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pxorl rd rs1 rs2 ::i k) - | Oxorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (xorimm64 rd rs n ::i k) - | Onxorl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pnxorl rd rs1 rs2 ::i k) - | Onxorlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (nxorimm64 rd rs n ::i k) - | Oandnl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pandnl rd rs1 rs2 ::i k) - | Oandnlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pandnil rd rs n ::i k) - | Oornl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pornl rd rs1 rs2 ::i k) - | Oornlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pornil rd rs n ::i k) - | Oshll, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Pslll rd rs1 rs2 ::i k) - | Oshllimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psllil rd rs n ::i k) - | Oshrl, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psral rd rs1 rs2 ::i k) - | Oshrlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrail rd rs n ::i k) - | Oshrlu, a1 :: a2 :: nil => - do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2; - OK (Psrll rd rs1 rs2 ::i k) - | Oshrluimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrlil rd rs n ::i k) - | Oshrxlimm n, a1 :: nil => - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Psrxil rd rs n ::i k) - | Omaddl, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - do r3 <- ireg_of a3; - OK (Pmaddl r1 r2 r3 ::i k) - | Omaddlimm n, a1 :: a2 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - OK (Pmaddil r1 r2 n ::i k) - | Omsubl, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do r1 <- ireg_of a1; - do r2 <- ireg_of a2; - do r3 <- ireg_of a3; - OK (Pmsubl r1 r2 r3 ::i k) - | Oabsf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabsd rd rs ::i k) - | Oabsfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfabsw rd rs ::i k) - | Oaddf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfaddd rd rs1 rs2 ::i k) - | Oaddfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfaddw rd rs1 rs2 ::i k) - | Osubf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsbfd rd rs1 rs2 ::i k) - | Osubfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfsbfw rd rs1 rs2 ::i k) - | Omulf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmuld rd rs1 rs2 ::i k) - | Omulfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmulw rd rs1 rs2 ::i k) - | Ominf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmind rd rs1 rs2 ::i k) - | Ominfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfminw rd rs1 rs2 ::i k) - | Omaxf, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmaxd rd rs1 rs2 ::i k) - | Omaxfs, a1 :: a2 :: nil => - do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2; - OK (Pfmaxw rd rs1 rs2 ::i k) - | Onegf, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegd rd rs ::i k) - | Onegfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnegw rd rs ::i k) - | Oinvfs, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfinvw rd rs ::i k) - - | Ofmaddf, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do rs1 <- freg_of a1; - do rs2 <- freg_of a2; - do rs3 <- freg_of a3; - OK (Pfmaddfl rs1 rs2 rs3 ::i k) - | Ofmaddfs, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do rs1 <- freg_of a1; - do rs2 <- freg_of a2; - do rs3 <- freg_of a3; - OK (Pfmaddfw rs1 rs2 rs3 ::i k) - | Ofmsubf, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do rs1 <- freg_of a1; - do rs2 <- freg_of a2; - do rs3 <- freg_of a3; - OK (Pfmsubfl rs1 rs2 rs3 ::i k) - | Ofmsubfs, a1 :: a2 :: a3 :: nil => - assertion (mreg_eq a1 res); - do rs1 <- freg_of a1; - do rs2 <- freg_of a2; - do rs3 <- freg_of a3; - OK (Pfmsubfw rs1 rs2 rs3 ::i k) - - | Osingleofint, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatwrnsz rd rs ::i k) - | Osingleofintu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatuwrnsz rd rs ::i k) - | Ofloatoflong, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatdrnsz rd rs ::i k) - | Ofloatoflongu, a1 :: nil => - do rd <- freg_of res; do rs <- ireg_of a1; - OK (Pfloatudrnsz rd rs ::i k) - | Ointofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixedwrzz rd rs ::i k) - | Ointuofsingle, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixeduwrzz rd rs ::i k) - | Olongoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixeddrzz rd rs ::i k) - | Ointoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixeddrzz_i32 rd rs ::i k) - | Ointuoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixedudrzz_i32 rd rs ::i k) - | Olonguoffloat, a1 :: nil => - do rd <- ireg_of res; do rs <- freg_of a1; - OK (Pfixedudrzz rd rs ::i k) - - | Ofloatofsingle, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfwidenlwd rd rs ::i k) - | Osingleoffloat, a1 :: nil => - do rd <- freg_of res; do rs <- freg_of a1; - OK (Pfnarrowdw rd rs ::i k) - - - | Odivf , _ => Error (msg "Asmblockgen.transl_op: Odivf") - | Odivfs, _ => Error (msg "Asmblockgen.transl_op: Odivfs") - - (* We use the Splitlong instead for these four conversions *) - | Osingleoflong , _ => Error (msg "Asmblockgen.transl_op: Osingleoflong") - | Osingleoflongu , _ => Error (msg "Asmblockgen.transl_op: Osingleoflongu") - | Olongofsingle , _ => Error (msg "Asmblockgen.transl_op: Olongofsingle") - | Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle") - - - | Ocmp cmp, _ => - do rd <- ireg_of res; - transl_cond_op cmp rd args k - - - | Oextfz stop start, a1 :: nil => - assertion (ExtValues.is_bitfield stop start); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pextfz stop start rd rs ::i k) - - | Oextfs stop start, a1 :: nil => - assertion (ExtValues.is_bitfield stop start); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pextfs stop start rd rs ::i k) - - | Oextfzl stop start, a1 :: nil => - assertion (ExtValues.is_bitfieldl stop start); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pextfzl stop start rd rs ::i k) - - | Oextfsl stop start, a1 :: nil => - assertion (ExtValues.is_bitfieldl stop start); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pextfsl stop start rd rs ::i k) - - | Oinsf stop start, a0 :: a1 :: nil => - assertion (ExtValues.is_bitfield stop start); - assertion (mreg_eq a0 res); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pinsf stop start rd rs ::i k) - - | Oinsfl stop start, a0 :: a1 :: nil => - assertion (ExtValues.is_bitfieldl stop start); - assertion (mreg_eq a0 res); - do rd <- ireg_of res; do rs <- ireg_of a1; - OK (Pinsfl stop start rd rs ::i k) - - | Osel cond0 ty, aT :: aF :: aC :: nil => - assertion (mreg_eq aT res); - do rT <- ireg_of aT; - do rF <- ireg_of aF; - do rC <- ireg_of aC; - do op <- conditional_move (negate_condition0 cond0) rC rT rF; - OK (op ::i k) - - | Oselimm cond0 imm, aT :: aC :: nil => - assertion (mreg_eq aT res); - do rT <- ireg_of aT; - do rC <- ireg_of aC; - do op <- conditional_move_imm32 (negate_condition0 cond0) rC rT imm; - OK (op ::i k) - - - | Osellimm cond0 imm, aT :: aC :: nil => - assertion (mreg_eq aT res); - do rT <- ireg_of aT; - do rC <- ireg_of aC; - do op <- conditional_move_imm64 (negate_condition0 cond0) rC rT imm; - OK (op ::i k) - - | _, _ => - Error(msg "Asmgenblock.transl_op") - end. - -(** Accessing data in the stack frame. *) - -Definition indexed_memory_access - (mk_instr: ireg -> offset -> basic) - (base: ireg) (ofs: ptrofs) := - match make_immed64 (Ptrofs.to_int64 ofs) with - | Imm64_single imm => - mk_instr base (Ptrofs.of_int64 imm) -end. - -Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) := - match ty, preg_of dst with - | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmblockgen.loadind") - end. - -Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode) := - match ty, preg_of src with - | Tint, IR rd => OK (indexed_memory_access (PStoreRRO Psw rd) base ofs ::i k) - | Tlong, IR rd => OK (indexed_memory_access (PStoreRRO Psd rd) base ofs ::i k) - | Tsingle, IR rd => OK (indexed_memory_access (PStoreRRO Pfss rd) base ofs ::i k) - | Tfloat, IR rd => OK (indexed_memory_access (PStoreRRO Pfsd rd) base ofs ::i k) - | Tany32, IR rd => OK (indexed_memory_access (PStoreRRO Psw_a rd) base ofs ::i k) - | Tany64, IR rd => OK (indexed_memory_access (PStoreRRO Psd_a rd) base ofs ::i k) - | _, _ => Error (msg "Asmblockgen.storeind") - end. - -Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) := - indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs. - -Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) := - indexed_memory_access (PStoreRRO Psd src) base ofs. - -(** Translation of memory accesses: loads, and stores. *) - -Definition transl_memory_access2 - (mk_instr: ireg -> ireg -> basic) - (addr: addressing) (args: list mreg) (k: bcode) : res bcode := - match addr, args with - | Aindexed2, a1 :: a2 :: nil => - do rs1 <- ireg_of a1; - do rs2 <- ireg_of a2; - OK (mk_instr rs1 rs2 ::i k) - | _, _ => Error (msg "Asmblockgen.transl_memory_access2") - end. - -Definition transl_memory_access2XS - (chunk: memory_chunk) - (mk_instr: ireg -> ireg -> basic) - scale (args: list mreg) (k: bcode) : res bcode := - match args with - | (a1 :: a2 :: nil) => - assertion (Z.eqb (zscale_of_chunk chunk) scale); - do rs1 <- ireg_of a1; - do rs2 <- ireg_of a2; - OK (mk_instr rs1 rs2 ::i k) - | _ => Error (msg "Asmblockgen.transl_memory_access2XS") - end. - -Definition transl_memory_access - (mk_instr: ireg -> offset -> basic) - (addr: addressing) (args: list mreg) (k: bcode) : res bcode := - match addr, args with - | Aindexed ofs, a1 :: nil => - do rs <- ireg_of a1; - OK (indexed_memory_access mk_instr rs ofs ::i k) - | Aglobal id ofs, nil => - OK (Ploadsymbol id ofs RTMP ::i (mk_instr RTMP Ptrofs.zero ::i k)) - | Ainstack ofs, nil => - OK (indexed_memory_access mk_instr SP ofs ::i k) - | _, _ => - Error(msg "Asmblockgen.transl_memory_access") - end. - -Definition chunk2load (chunk: memory_chunk) := - match chunk with - | Mint8signed => Plb - | Mint8unsigned => Plbu - | Mint16signed => Plh - | Mint16unsigned => Plhu - | Mint32 => Plw - | Mint64 => Pld - | Mfloat32 => Pfls - | Mfloat64 => Pfld - | Many32 => Plw_a - | Many64 => Pld_a - end. - -Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - do r <- ireg_of dst; - transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k. - -Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - do r <- ireg_of dst; - transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k. - -Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z) - (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - do r <- ireg_of dst; - transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k. - -Definition transl_load (trap : trapping_mode) - (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (dst: mreg) (k: bcode) : res bcode := - match addr with - | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k - | Aindexed2 => transl_load_rrr trap chunk addr args dst k - | _ => transl_load_rro trap chunk addr args dst k - end. - -Definition chunk2store (chunk: memory_chunk) := - match chunk with - | Mint8signed | Mint8unsigned => Psb - | Mint16signed | Mint16unsigned => Psh - | Mint32 => Psw - | Mint64 => Psd - | Mfloat32 => Pfss - | Mfloat64 => Pfsd - | Many32 => Psw_a - | Many64 => Psd_a - end. - -Definition transl_store_rro (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: bcode) : res bcode := - do r <- ireg_of src; - transl_memory_access (PStoreRRO (chunk2store chunk) r) addr args k. - -Definition transl_store_rrr (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: bcode) : res bcode := - do r <- ireg_of src; - transl_memory_access2 (PStoreRRR (chunk2store chunk) r) addr args k. - -Definition transl_store_rrrxs (chunk: memory_chunk) (scale: Z) - (args: list mreg) (src: mreg) (k: bcode) : res bcode := - do r <- ireg_of src; - transl_memory_access2XS chunk (PStoreRRRXS (chunk2store chunk) r) scale args k. - -Definition transl_store (chunk: memory_chunk) (addr: addressing) - (args: list mreg) (src: mreg) (k: bcode) : res bcode := - match addr with - | Aindexed2 => transl_store_rrr chunk addr args src k - | Aindexed2XS scale => transl_store_rrrxs chunk scale args src k - | _ => transl_store_rro chunk addr args src k - end. - -(** Function epilogue *) - -Definition make_epilogue (f: Machblock.function) (k: code) := - (loadind_ptr SP f.(fn_retaddr_ofs) GPRA) - ::g Pset RA GPRA ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k. - -(** Translation of a Machblock instruction. *) - -Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst) - (ep: bool) (k: bcode) := - match i with - | MBgetstack ofs ty dst => - loadind SP ofs ty dst k - | MBsetstack src ofs ty => - storeind src SP ofs ty k - | MBgetparam ofs ty dst => - (* load via the frame pointer if it is valid *) - do c <- loadind FP ofs ty dst k; - OK (if ep then c - else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c) - | MBop op args res => - transl_op op args res k - | MBload trap chunk addr args dst => - transl_load trap chunk addr args dst k - | MBstore chunk addr args src => - transl_store chunk addr args src k - end. - -Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.control_flow_inst) - : res code := - match oi with - | None => OK nil - | Some i => - match i with - | MBcall sig (inl r) => - do r1 <- ireg_of r; OK ((Picall r1) ::g nil) - | MBcall sig (inr symb) => - OK ((Pcall symb) ::g nil) - | MBtailcall sig (inr symb) => - OK (make_epilogue f ((Pgoto symb) ::g nil)) - | MBtailcall sig (inl r) => - do r1 <- ireg_of r; OK (make_epilogue f ((Pigoto r1) ::g nil)) - | MBbuiltin ef args res => - OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) ::g nil) - | MBgoto lbl => - OK (Pj_l lbl ::g nil) - | MBcond cond args lbl => - transl_cbranch cond args lbl nil - | MBreturn => - OK (make_epilogue f (Pret ::g nil)) - | MBjumptable arg tbl => - do r <- ireg_of arg; - OK (Pjumptable r tbl ::g nil) - end - end. - -(** Translation of a code sequence *) - -Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool := - match i with - | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP) - | MBsetstack src ofs ty => before - | MBgetparam ofs ty dst => negb (mreg_eq dst MFP) - | MBop op args res => before && negb (mreg_eq res MFP) - | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP) - | MBstore chunk addr args res => before - end. - -(** This is the naive definition, which is not tail-recursive unlike the other backends *) - -Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := - match il with - | nil => OK nil - | i1 :: il' => - do k <- transl_basic_code f il' (fp_is_parent it1p i1); - transl_instr_basic f i1 it1p k - end. - -(* (** This is an equivalent definition in continuation-passing style - that runs in constant stack space. *) - -Fixpoint transl_basic_rec (f: Machblock.function) (il: list Machblock.basic_inst) - (it1p: bool) (k: bcode -> res bcode) := - match il with - | nil => k nil - | i1 :: il' => - transl_basic_rec f il' (fp_is_parent it1p i1) - (fun c1 => do c2 <- transl_instr_basic f i1 it1p c1; k c2) - end. - -Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) := - transl_basic_rec f il it1p (fun c => OK c). *) - -(** Translation of a whole function. Note that we must check - that the generated code contains less than [2^64] instructions, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) - -(* gen_bblocks can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *) -Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) := - match (extract_ctl ctl) with - | None => - match c with - | nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil - | i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil - end - | Some (PExpand (Pbuiltin ef args res)) => - match c with - | nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil - | _ => {| header := hd; body := c; exit := None |} - :: {| header := nil; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil - end - | Some ex => {| header := hd; body := (c ++ extract_basic ctl); exit := Some ex |} :: nil - end -. -Next Obligation. - apply wf_bblock_refl. constructor. - left. auto. - discriminate. -Qed. Next Obligation. - apply wf_bblock_refl. constructor. - right. discriminate. - unfold builtin_alone. intros. pose (H ef args res). rewrite H0 in n. contradiction. -Qed. - -Definition transl_block (f: Machblock.function) (fb: Machblock.bblock) (ep: bool) : res (list bblock) := - do c <- transl_basic_code f fb.(Machblock.body) ep; - do ctl <- transl_instr_control f fb.(Machblock.exit); - OK (gen_bblocks fb.(Machblock.header) c ctl) -. - -Fixpoint transl_blocks (f: Machblock.function) (lmb: list Machblock.bblock) (ep: bool) := - match lmb with - | nil => OK nil - | mb :: lmb => - do lb <- transl_block f mb (if Machblock.header mb then ep else false); - do lb' <- transl_blocks f lmb false; - OK (lb @@ lb') - end -. - -Program Definition make_prologue (f: Machblock.function) lb := - ({| header := nil; body := Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::i - Pget GPRA RA ::i - storeind_ptr GPRA SP f.(fn_retaddr_ofs) ::i nil; - exit := None |} :: lb). - -Definition transl_function (f: Machblock.function) := - do lb <- transl_blocks f f.(Machblock.fn_code) true; - OK (mkfunction f.(Machblock.fn_sig) - (make_prologue f lb)). - -Definition transf_function (f: Machblock.function) : res Asmvliw.function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: Machblock.fundef) : res Asmvliw.fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: Machblock.program) : res Asmvliw.program := - transform_partial_program transf_fundef p. diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v deleted file mode 100644 index 5cb498bc..00000000 --- a/mppa_k1c/Asmblockgenproof.v +++ /dev/null @@ -1,1807 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Correctness proof for RISC-V generation: main proof. *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops. -Require Import Axioms. - -Module MB := Machblock. -Module AB := Asmvliw. - -Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Section PRESERVATION. - -Variable prog: Machblock.program. -Variable tprog: Asmvliw.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSF). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit functions_translated; eauto. intros [tf' [A B]]. - monadInv B. rewrite H0 in EQ; inv EQ; auto. -Qed. - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - -Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *) - -Lemma gen_bblocks_label: - forall hd bdy ex tbb tc, - gen_bblocks hd bdy ex = tbb::tc -> - header tbb = hd. -Proof. - intros until tc. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Lemma gen_bblocks_label2: - forall hd bdy ex tbb1 tbb2, - gen_bblocks hd bdy ex = tbb1::tbb2::nil -> - header tbb2 = nil. -Proof. - intros until tbb2. intros GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy. - all: inv GENB; simpl; auto. -Qed. - -Remark in_dec_transl: - forall lbl hd, - (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false). -Proof. - intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto. -Qed. - -Lemma transl_is_label: - forall lbl bb tbb f ep tc, - transl_block f bb ep = OK (tbb::tc) -> - is_label lbl tbb = MB.is_label lbl bb. -Proof. - intros until tc. intros TLB. - destruct tbb as [thd tbdy tex]; simpl in *. - monadInv TLB. - unfold is_label. simpl. - apply gen_bblocks_label in H0. simpl in H0. subst. - rewrite in_dec_transl. auto. -Qed. - -Lemma transl_is_label_false2: - forall lbl bb f ep tbb1 tbb2, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb2 = false. -Proof. - intros until tbb2. intros TLB. - destruct tbb2 as [thd tbdy tex]; simpl in *. - monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst. - apply is_label_correct_false. simpl. auto. -Qed. - -Lemma transl_is_label2: - forall f bb ep tbb1 tbb2 lbl, - transl_block f bb ep = OK (tbb1::tbb2::nil) -> - is_label lbl tbb1 = MB.is_label lbl bb - /\ is_label lbl tbb2 = false. -Proof. - intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto. -Qed. - -Lemma transl_block_nonil: - forall f c ep tc, - transl_block f c ep = OK tc -> - tc <> nil. -Proof. - intros. monadInv H. unfold gen_bblocks. - destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i. - all: discriminate. -Qed. - -Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc, - ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc). -Proof. - intros. intro. monadInv H. - unfold gen_bblocks in H0. - destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i. - all: discriminate. -Qed. - -Lemma find_label_transl_false: - forall x f lbl bb ep x', - transl_block f bb ep = OK x -> - MB.is_label lbl bb = false -> - find_label lbl (x++x') = find_label lbl x'. -Proof. - intros until x'. intros TLB MBis; simpl; auto. - destruct x as [|x0 x1]; simpl; auto. - destruct x1 as [|x1 x2]; simpl; auto. - - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto. - - destruct x2 as [|x2 x3]; simpl; auto. - + erewrite <- transl_is_label in MBis; eauto. rewrite MBis. - erewrite transl_is_label_false2; eauto. - + apply transl_block_limit in TLB. destruct TLB. -Qed. - -Lemma transl_blocks_label: - forall lbl f c tc ep, - transl_blocks f c ep = OK tc -> - match MB.find_label lbl c with - | None => find_label lbl tc = None - | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc' - end. -Proof. - induction c; simpl; intros. - inv H. auto. - monadInv H. - destruct (MB.is_label lbl a) eqn:MBis. - - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. } - simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis. - rewrite ABis. - eexists. eexists. split; eauto. simpl transl_blocks. - assert (MB.header a <> nil). - { apply MB.is_label_correct_true in MBis. - destruct (MB.header a). contradiction. discriminate. } - destruct (MB.header a); try contradiction. - rewrite EQ. simpl. rewrite EQ1. simpl. auto. - - apply IHc in EQ1. destruct (MB.find_label lbl c). - + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto. - erewrite find_label_transl_false; eauto. - + erewrite find_label_transl_false; eauto. -Qed. - -Lemma find_label_nil: - forall bb lbl c, - header bb = nil -> - find_label lbl (bb::c) = find_label lbl c. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. subst. - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { erewrite <- is_label_correct_false. simpl. auto. } - rewrite H. auto. -Qed. - -Theorem transl_find_label: - forall lbl f tf, - transf_function f = OK tf -> - match MB.find_label lbl f.(MB.fn_code) with - | None => find_label lbl tf.(fn_blocks) = None - | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc - end. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g. - monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto. - eapply transl_blocks_label; eauto. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Machblock code translates to a valid ``go to'' - transition in the generated Asmblock code. *) - -Lemma find_label_goto_label: - forall f tf lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - transf_function f = OK tf -> - rs PC = Vptr b ofs -> - MB.find_label lbl f.(MB.fn_code) = Some c' -> - exists tc', exists rs', - goto_label tf lbl rs m = Next rs' m - /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2. - intros (tc & A & B). - exploit label_pos_code_tail; eauto. instantiate (1 := 0). - intros [pos' [P [Q R]]]. - exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))). - split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto. - split. rewrite Pregmap.gss. constructor; auto. - rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q. - auto. omega. - generalize (transf_function_no_overflow _ _ H0). omega. - intros. apply Pregmap.gso; auto. -Qed. - -(** Existence of return addresses *) - -Lemma return_address_exists: - forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. eapply Asmblockgenproof0.return_address_exists; eauto. - -- intros. monadInv H0. - destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl. - exists x; exists true; split; auto. - repeat constructor. -- exact transf_function_no_overflow. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using a complex simulation diagram - of the following form. -<< - MB.step - ----------------------------------------> - header body exit - st1 -----> st2 -----> st3 ------------------> st4 - | | | | - | (A) | (B) | (C) | - match_codestate | | | | - | header | body1 | body2 | match_states - cs1 -----> cs2 -----> cs3 ------> cs4 | - | / \ exit | - match_asmstate | --------------- --->--- | - | / match_asmstate \ | - st'1 ---------------------------------------> st'2 - AB.step * ->> - The invariant between each MB.step/AB.step is the [match_states] predicate below. - However, we also need to introduce an intermediary state [Codestate] which allows - us to reason on a finer grain, executing header, body and exit separately. - - This [Codestate] consists in a state like [Asmblock.State], except that the - code is directly stored in the state, much like [Machblock.State]. It also features - additional useful elements to keep track of while executing a bblock. -*) - -Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r. -Proof. - intros. change (IR FP) with (preg_of MFP). red; intros. - exploit preg_of_injective; eauto. intros; subst r; discriminate. -Qed. - -Inductive match_states: Machblock.state -> Asmvliw.state -> Prop := - | match_states_intro: - forall s fb sp c ep ms m m' rs f tf tc - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m') - (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc) - (AG: agree ms sp rs) - (DXP: ep = true -> rs#FP = parent_sp s), - match_states (Machblock.State s fb sp c ms m) - (Asmvliw.State rs m') - | match_states_call: - forall s fb ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = Vptr fb Ptrofs.zero) - (ATLR: rs RA = parent_ra s), - match_states (Machblock.Callstate s fb ms m) - (Asmvliw.State rs m') - | match_states_return: - forall s ms m m' rs - (STACKS: match_stack ge s) - (MEXT: Mem.extends m m') - (AG: agree ms (parent_sp s) rs) - (ATPC: rs PC = parent_ra s), - match_states (Machblock.Returnstate s ms m) - (Asmvliw.State rs m'). - -Record codestate := - Codestate { pstate: state; (**r projection to Asmblock.state *) - pheader: list label; - pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *) - pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *) - pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *) - ep: bool; (**r reflects the [ep] variable used in the translation *) - rem: list AB.bblock; (**r remaining bblocks to execute *) - cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *) - }. - -(* The part that deals with Machblock <-> Codestate agreement - * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *) -Inductive match_codestate fb: Machblock.state -> codestate -> Prop := - | match_codestate_intro: - forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi - (STACKS: match_stack ge s) - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (MEXT: Mem.extends m m0) - (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc) - (TIC: transl_instr_control f (MB.exit bb) = OK tbi) - (TBLS: transl_blocks f c false = OK tc) - (AG: agree ms sp rs0) - (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s) - , - match_codestate fb (Machblock.State s fb sp (bb::c) ms m) - {| pstate := (Asmvliw.State rs0 m0); - pheader := (MB.header bb); - pbody1 := tbc; - pbody2 := extract_basic tbi; - pctl := extract_ctl tbi; - ep := ep; - rem := tc; - cur := tbb - |} -. - -(* The part ensuring that the code in Codestate actually resides at [rs PC] *) -Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop := - | match_asmstate_some: - forall rs f tf tc m tbb ofs ep tbdy tex lhd - (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) - (TRANSF: transf_function f = OK tf) - (PCeq: rs PC = Vptr fb ofs) - (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc)) - , - match_asmstate fb - {| pstate := (Asmvliw.State rs m); - pheader := lhd; - pbody1 := tbdy; - pbody2 := extract_basic tex; - pctl := extract_ctl tex; - ep := ep; - rem := tc; - cur := tbb |} - (Asmvliw.State rs m) -. - -(* Useful for dealing with the many cases in some proofs *) -Ltac exploreInst := - repeat match goal with - | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var - | [ H : OK _ = OK _ |- _ ] => monadInv H - | [ |- context[if ?b then _ else _] ] => destruct b - | [ |- context[match ?m with | _ => _ end] ] => destruct m - | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m - | [ H : bind _ _ = OK _ |- _ ] => monadInv H - | [ H : Error _ = OK _ |- _ ] => inversion H - end. - -(** Some translation properties *) - -Lemma transl_blocks_nonil: - forall f bb c tc ep, - transl_blocks f (bb::c) ep = OK tc -> - exists tbb tc', tc = tbb :: tc'. -Proof. - intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks. - destruct (extract_ctl x2). - - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto. - - destruct x1; simpl; eauto. -Qed. - -Lemma no_builtin_preserved: - forall f ex x2, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x2 -> - (exists i, extract_ctl x2 = Some (PCtlFlow i)) - \/ extract_ctl x2 = None. -Proof. - intros until x2. intros Hbuiltin TIC. - destruct ex. - - destruct c. - (* MBcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBtailcall *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBbuiltin *) - + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)). - apply Hbuiltin. contradict H; auto. - (* MBgoto *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBcond *) - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto. - * unfold transl_opt_compuimm. exploreInst; simpl; eauto. - * unfold transl_opt_compluimm. exploreInst; simpl; eauto. - * unfold transl_comp_float64. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat64. exploreInst; simpl; eauto. - * unfold transl_comp_float32. exploreInst; simpl; eauto. - * unfold transl_comp_notfloat32. exploreInst; simpl; eauto. - (* MBjumptable *) - + simpl in TIC. exploreInst; simpl; eauto. - (* MBreturn *) - + simpl in TIC. monadInv TIC. simpl. eauto. - - monadInv TIC. simpl; auto. -Qed. - -Lemma transl_blocks_distrib: - forall c f bb tbb tc ep, - transl_blocks f (bb::c) ep = OK (tbb::tc) - -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) - -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil) - /\ transl_blocks f c false = OK tc. -Proof. - intros until ep0. intros TLBS Hbuiltin. - destruct bb as [hd bdy ex]. - monadInv TLBS. monadInv EQ. - exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl. - - destruct H as [i Hectl]. - unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0. - simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite Hectl. auto. - - unfold gen_bblocks in H0. rewrite H in H0. - destruct x1 as [|bi x1]. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. - + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl. - unfold gen_bblocks. rewrite H. auto. -Qed. - -Lemma gen_bblocks_nobuiltin: - forall thd tbdy tex tbb, - (tbdy <> nil \/ extract_ctl tex <> None) -> - (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) -> - gen_bblocks thd tbdy tex = tbb :: nil -> - header tbb = thd - /\ body tbb = tbdy ++ extract_basic tex - /\ exit tbb = extract_ctl tex. -Proof. - intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB. - destruct (extract_ctl tex) eqn:ECTL. - - destruct c. - + destruct i; try (inv GENB; simpl; auto; fail). - assert False. eapply Hnobuiltin. eauto. destruct H. - + inv GENB. simpl. auto. - - inversion Hnonil. - + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto. - + contradict H; simpl; auto. -Qed. - -Lemma transl_instr_basic_nonil: - forall k f bi ep x, - transl_instr_basic f bi ep k = OK x -> - x <> nil. -Proof. - intros until x. intros TIB. - destruct bi. - - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate. - - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate. - - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate. - - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate. - unfold transl_cond_op in EQ0. exploreInst; try discriminate. - unfold transl_cond_float64. exploreInst; try discriminate. - unfold transl_cond_notfloat64. exploreInst; try discriminate. - unfold transl_cond_float32. exploreInst; try discriminate. - unfold transl_cond_notfloat32. exploreInst; try discriminate. - - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. - - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate. - all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate. -Qed. - -Lemma transl_basic_code_nonil: - forall bdy f x ep, - bdy <> nil -> - transl_basic_code f bdy ep = OK x -> - x <> nil. -Proof. - induction bdy as [|bi bdy]. - intros. contradict H0; auto. - destruct bdy as [|bi2 bdy]. - - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto. - - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'. - monadInv TBC. - assert (x0 <> nil). - eapply IHbdy; eauto. subst bdy'. discriminate. - eapply transl_instr_basic_nonil; eauto. -Qed. - -Lemma transl_instr_control_nonil: - forall ex f x, - ex <> None -> - transl_instr_control f ex = OK x -> - extract_ctl x <> None. -Proof. - intros ex f x Hnonil TIC. - destruct ex as [ex|]. - - clear Hnonil. destruct ex. - all: try (simpl in TIC; exploreInst; discriminate). - + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate. - * unfold transl_opt_compuimm. exploreInst; try discriminate. - * unfold transl_opt_compluimm. exploreInst; try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. - - contradict Hnonil; auto. -Qed. - -Lemma transl_instr_control_nobuiltin: - forall f ex x, - (forall ef args res, ex <> Some (MBbuiltin ef args res)) -> - transl_instr_control f ex = OK x -> - (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))). -Proof. - intros until x. intros Hnobuiltin TIC. intros until res. - unfold transl_instr_control in TIC. exploreInst. - all: try discriminate. - - assert False. eapply Hnobuiltin; eauto. destruct H. - - unfold transl_cbranch in TIC. exploreInst. - all: try discriminate. - * unfold transl_opt_compuimm. exploreInst. all: try discriminate. - * unfold transl_opt_compluimm. exploreInst. all: try discriminate. - * unfold transl_comp_float64. exploreInst; try discriminate. - * unfold transl_comp_notfloat64. exploreInst; try discriminate. - * unfold transl_comp_float32. exploreInst; try discriminate. - * unfold transl_comp_notfloat32. exploreInst; try discriminate. -Qed. - -(* Proving that one can decompose a [match_state] relation into a [match_codestate] - and a [match_asmstate], along with some helpful properties tying both relations together *) - -Theorem match_state_codestate: - forall mbs abs s fb sp bb c ms m, - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - (MB.body bb <> nil \/ MB.exit bb <> None) -> - mbs = (Machblock.State s fb sp (bb::c) ms m) -> - match_states mbs abs -> - exists cs fb f tbb tc ep, - match_codestate fb mbs cs /\ match_asmstate fb cs abs - /\ Genv.find_funct_ptr ge fb = Some (Internal f) - /\ transl_blocks f (bb::c) ep = OK (tbb::tc) - /\ body tbb = pbody1 cs ++ pbody2 cs - /\ exit tbb = pctl cs - /\ cur cs = tbb /\ rem cs = tc - /\ pstate cs = abs. -Proof. - intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS. - inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. - exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2. - monadInv TLB. exploit gen_bblocks_nobuiltin; eauto. - { inversion Hnotempty. - - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail). - left. eapply transl_basic_code_nonil; eauto. - - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail). - right. eapply transl_instr_control_nonil; eauto. } - eapply transl_instr_control_nobuiltin; eauto. - intros (Hth & Htbdy & Htexit). - exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0; - pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0. - repeat split. 1-2: econstructor; eauto. - { destruct (MB.header bb). eauto. discriminate. } eauto. - unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl. - rewrite TLBS. simpl. rewrite H2. - all: simpl; auto. -Qed. - -Definition mb_remove_body (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}. - -Lemma exec_straight_pnil: - forall c rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 -> - exec_straight tge c rs1 m1 nil rs2 m2. -Proof. - intros. eapply exec_straight_trans. eapply H. econstructor; eauto. -Qed. - -Lemma transl_block_nobuiltin: - forall f bb ep tbb, - (MB.body bb <> nil \/ MB.exit bb <> None) -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - transl_block f bb ep = OK (tbb :: nil) -> - exists c c', - transl_basic_code f (MB.body bb) ep = OK c - /\ transl_instr_control f (MB.exit bb) = OK c' - /\ body tbb = c ++ extract_basic c' - /\ exit tbb = extract_ctl c'. -Proof. - intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. - - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto. - right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto. -Qed. - -Lemma nextblock_preserves: - forall rs rs' bb r, - rs' = nextblock bb rs -> - data_preg r = true -> - rs r = rs' r. -Proof. - intros. destruct r; try discriminate. - subst. Simpl. -Qed. - -Remark cons3_app {A: Type}: - forall a b c (l: list A), - a :: b :: c :: l = (a :: b :: c :: nil) ++ l. -Proof. - intros. simpl. auto. -Qed. - -Lemma exec_straight_opt_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight_opt tge c rs1 m1 c' rs2 m2 -> - exists body, - exec_body tge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. intros EXES. - inv EXES. - - exists nil. split; auto. - - eapply exec_straight_body2. auto. -Qed. - -Lemma extract_basics_to_code: - forall lb c, - extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -Lemma extract_ctl_basics_to_code: - forall lb c, - extract_ctl (basics_to_code lb ++ c) = extract_ctl c. -Proof. - induction lb; intros; simpl; congruence. -Qed. - -(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are - unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by - yourself the steps *) -Theorem step_simu_control: - forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2, - MB.body bb' = nil -> - (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) -> - Genv.find_funct_ptr tge fb = Some (Internal fn) -> - pstate cs2 = (Asmvliw.State rs2 m2) -> - pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex -> - cur cs2 = tbb -> - match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 -> - match_asmstate fb cs2 (Asmvliw.State rs1 m1) -> - exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' -> - (exists rs3 m3 rs4 m4, - exec_body tge tbdy2 rs2 m2 = Next rs3 m3 - /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4 - /\ match_states S'' (State rs4 m4)). -Proof. - intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP. - inv ESTEP. - - inv MCS. inv MAS. simpl in *. - inv Hpstate. - destruct ctl. - + (* MBcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - destruct s1 as [rf|fid]; simpl in H7. - * (* Indirect call *) - monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate. - revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - { econstructor; eauto. } - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto. - - * (* Direct call *) - monadInv H1. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - remember (Ptrofs.add _ _) as ofs'. - assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc). - econstructor; eauto. - assert (f1 = f) by congruence. subst f1. - exploit return_address_offset_correct; eauto. intros; subst ra. - repeat eexists. - rewrite H6. econstructor; eauto. - rewrite H7. econstructor; eauto. - econstructor; eauto. - econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl. - Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto. - Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto. - + (* MBtailcall *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]]. - destruct s1 as [rf|fid]; simpl in H13. - * monadInv H1. - assert (ms' rf = Vptr f' Ptrofs.zero). - { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. } - assert (rs2 x = Vptr f' Ptrofs.zero). - { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. } - - assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - { simpl. eauto. } - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16). - { clear - EQ. destruct x; repeat split; try discriminate. - all: unfold ireg_of in EQ; destruct rf; try discriminate. } - Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate. - * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - { apply agree_set_other. - - econstructor; auto with asmgen. - + apply V. - + intro r. destruct r; apply V; auto. - - eauto with asmgen. } - { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. } - + (* MBbuiltin (contradiction) *) - assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin). - rewrite <- H in H1. contradict H1; auto. - + (* MBgoto *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11. - remember (nextblock tbb rs2) as rs2'. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - exploit find_label_goto_label. - eauto. eauto. - instantiate (2 := rs2'). - { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. } - eauto. - intros (tc' & rs' & GOTO & AT2 & INV). - - eexists. eexists. repeat eexists. repeat split. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto. - econstructor; eauto. - rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV. - eapply agree_exten; eauto with asmgen. - assert (forall r : preg, r <> PC -> rs' r = rs2 r). - { intros. destruct r. - - destruct g. all: rewrite INV; Simpl; auto. - - rewrite INV; Simpl; auto. - - contradiction. } - eauto with asmgen. - congruence. - + (* MBcond *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - * (* MBcond true *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. - 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc. - unfold Val.offset_ptr. rewrite PCeq. eauto. - intros (tc' & rs3 & GOTOL & TLPC & Hrs3). - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - - * (* MBcond false *) - assert (f0 = f) by congruence. subst f0. - exploit eval_condition_lessdef. - eapply preg_vals; eauto. - all: eauto. - intros EC. - - exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C). - exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC). - assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. } - rewrite PCeq' in PCeq. - exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'. - assert (tf = fn) by congruence. subst tf. - - assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. - - repeat eexists. - rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto. - rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto. - - econstructor; eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto. - eapply agree_exten with rs2; eauto with asmgen. - { intros. destruct r; try destruct g; try discriminate. - all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. } - intros. discriminate. - + (* MBjumptable *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - monadInv H1. - generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV. - assert (f1 = f) by congruence. subst f1. - exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef). - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity. - exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn. - - intros [tc' [rs' [A [B C]]]]. - exploit ireg_val; eauto. rewrite H13. intros LD; inv LD. - - repeat eexists. - rewrite H6. simpl extract_basic. simpl. eauto. - rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A. - econstructor; eauto. - eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen. - { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0. - destruct (preg_eq r' GPR63). subst. contradiction. - destruct (preg_eq r' GPR62). subst. contradiction. - destruct r'; Simpl. } - discriminate. - + (* MBreturn *) - destruct bb' as [mhd' mbdy' mex']; simpl in *. subst. - inv TBC. inv TIC. inv H0. - - assert (f0 = f) by congruence. subst f0. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z). - exploit exec_straight_body; eauto. - simpl. eauto. - intros EXEB. - assert (f1 = f) by congruence. subst f1. - - repeat eexists. - rewrite H6. simpl extract_basic. eauto. - rewrite H7. simpl extract_ctl. simpl. reflexivity. - econstructor; eauto. - unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen. - - - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. - destruct bb' as [hd' bdy' ex']; simpl in *. subst. - monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6. - simpl. repeat eexists. - econstructor. 4: instantiate (3 := false). all:eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - assert (f = f0) by congruence. subst f0. econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - discriminate. -Qed. - -Definition mb_remove_first (bb: MB.bblock) := - {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}. - -Lemma exec_straight_body: - forall c c' lc rs1 m1 rs2 m2, - exec_straight tge c rs1 m1 c' rs2 m2 -> - code_to_basics c = Some lc -> - exists l ll, - c = l ++ c' - /\ code_to_basics l = Some ll - /\ exec_body tge ll rs1 m1 = Next rs2 m2. -Proof. - induction c; try (intros; inv H; fail). - intros until m2. intros EXES CTB. inv EXES. - - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto. - - inv CTB. destruct (code_to_basics c); try discriminate. inv H0. - eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst. - exists (i ::g l'),(i::ll). repeat (split; simpl; auto). - rewrite CTB. auto. - rewrite H1. auto. -Qed. - -Lemma basics_to_code_app: - forall c l x ll, - basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - c = ll ++ x. -Proof. - intros. apply (f_equal code_to_basics) in H. - erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id. - rewrite code_to_basics_id in H. inv H. auto. -Qed. - -Lemma basics_to_code_app2: - forall i c l x ll, - (PBasic i) :: basics_to_code c = l ++ basics_to_code x -> - code_to_basics l = Some ll -> - i :: c = ll ++ x. -Proof. - intros until ll. intros. - exploit basics_to_code_app. instantiate (3 := (i::c)). simpl. - all: eauto. -Qed. - -(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *) -Theorem step_simu_basic: - forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy, - MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} -> - basic_step ge s fb sp ms m bi ms' m' -> - pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 l cs2 tbdy', - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |} - /\ tbdy = l ++ tbdy' - /\ exec_body tge l rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2). -Proof. - intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS. - simpl in *. inv Hpstate. - rewrite Hbody in TBC. monadInv TBC. - inv BSTEP. - - - (* MBgetstack *) - simpl in EQ0. - unfold Mach.load_stack in H. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ AG) in A. - exploit loadind_correct; eauto with asmgen. - intros (rs2 & EXECS & Hrs'1 & Hrs'2). - eapply exec_straight_body in EXECS. - 2: eapply code_to_basics_id; eauto. - destruct EXECS as (l & Hlbi & BTC & CTB & EXECB). - exists rs2, m1, Hlbi. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - subst. simpl in Hheadereq. - - eapply match_codestate_intro; eauto. - { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. } - eapply agree_set_mreg; eauto with asmgen. - intro Hep. simpl in Hep. - destruct (andb_prop _ _ Hep). clear Hep. - rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity. - discriminate. apply preg_of_not_FP; assumption. reflexivity. - - - (* MBsetstack *) - simpl in EQ0. - unfold Mach.store_stack in H. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. } - exploit Mem.storev_extends; eauto. intros [m2' [A B]]. - exploit storeind_correct; eauto with asmgen. - rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs', m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - - eapply agree_undef_regs; eauto with asmgen. - simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto. - - (* MBgetparam *) - simpl in EQ0. - - assert (f0 = f) by congruence; subst f0. - unfold Mach.load_stack in *. - exploit Mem.loadv_extends. eauto. eexact H0. auto. - intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'. - exploit Mem.loadv_extends. eauto. eexact H1. auto. - intros [v' [C D]]. - - monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP. - destruct ep0 eqn:EPeq. - - (* RTMP contains parent *) - + exploit loadind_correct. eexact EQ1. - instantiate (2 := rs1). rewrite DXP; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & BTC & CTB & EXECB). - exists rs2, m1, ll. eexists. - eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - { eapply basics_to_code_app; eauto. } - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. } - subst. - eapply match_codestate_intro; eauto. - - eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen. - simpl; intros. rewrite R; auto with asmgen. - apply preg_of_not_FP; auto. - - (* RTMP does not contain parent *) - + rewrite chunk_of_Tptr in A. - exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]]. - exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto. - intros [rs3 [S [T U]]]. - - exploit exec_straight_trans. - eapply P. - eapply S. - intros EXES. - - eapply exec_straight_body in EXES. - 2: simpl. 2: erewrite code_to_basics_id; eauto. - destruct EXES as (l & ll & BTC & CTB & EXECB). - exists rs3, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app2; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. - eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto. - instantiate (1 := rs2#FP <- (rs3#FP)). intros. - rewrite Pregmap.gso; auto with asmgen. - congruence. - intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen. - simpl; intros. rewrite U; auto with asmgen. - apply preg_of_not_FP; auto. - - (* MBop *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_operation tge sp op (map ms args) m' = Some v). - rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. - exploit eval_operation_lessdef. - eapply preg_vals; eauto. - 2: eexact H0. - all: eauto. - intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto. - apply agree_set_undef_mreg with rs1; auto. - apply Val.lessdef_trans with v'; auto. - simpl; intros. destruct (andb_prop _ _ H1); clear H1. - rewrite R; auto. apply preg_of_not_FP; auto. -Local Transparent destroyed_by_op. - destruct op; simpl; auto; congruence. - - (* MBload *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - exploit Mem.loadv_extends; eauto. intros [v' [C D]]. - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - rewrite <- Hheadereq in EQ. assumption. - eapply agree_set_mreg; eauto with asmgen. - intro Hep. simpl in Hep. - destruct (andb_prop _ _ Hep). clear Hep. - subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity. - apply preg_of_not_FP; assumption. reflexivity. - - - (* notrap1 cannot happen *) - simpl in EQ0. unfold transl_load in EQ0. - destruct addr; simpl in H. - all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0; - monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2; - destruct args as [|h0 t0]; try discriminate; - destruct t0 as [|h1 t1]; try discriminate; - destruct t1 as [|h2 t2]; try discriminate. - - - (* MBload notrap2 TODO *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - - destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload. - { - exploit transl_load_correct; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. - simpl in EQ. assumption. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - - simpl. intro. - rewrite R; try congruence. - apply DXP. - destruct ep0; simpl in *; congruence. - apply preg_of_not_FP. - destruct ep0; simpl in *; congruence. - } - { - exploit transl_load_correct_notrap2; eauto. - intros [rs2 [P [Q R]]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m1, ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. -(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - rewrite <- Hheadereq. *) subst. - eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption. - - eapply agree_set_undef_mreg; eauto. intros; auto with asmgen. - simpl. intro. - rewrite R; try congruence. - apply DXP. - destruct ep0; simpl in *; congruence. - apply preg_of_not_FP. - destruct ep0; simpl in *; congruence. - } - - (* MBstore *) - simpl in EQ0. rewrite Hheader in DXP. - - assert (eval_addressing tge sp addr (map ms args) = Some a). - rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1. - intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A. - assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto. - exploit Mem.storev_extends; eauto. intros [m2' [C D]]. - exploit transl_store_correct; eauto. intros [rs2 [P Q]]. - - eapply exec_straight_body in P. - 2: eapply code_to_basics_id; eauto. - destruct P as (l & ll & TBC & CTB & EXECB). - exists rs2, m2', ll. - eexists. eexists. split. instantiate (1 := x). eauto. - repeat (split; auto). - eapply basics_to_code_app; eauto. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'. - assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. } - subst. - eapply match_codestate_intro; eauto. simpl. simpl in EQ. - rewrite <- Hheadereq in EQ. assumption. - eapply agree_undef_regs; eauto with asmgen. - intro Hep. simpl in Hep. - subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity. -Qed. - -Lemma exec_body_trans: - forall l l' rs0 m0 rs1 m1 rs2 m2, - exec_body tge l rs0 m0 = Next rs1 m1 -> - exec_body tge l' rs1 m1 = Next rs2 m2 -> - exec_body tge (l++l') rs0 m0 = Next rs2 m2. -Proof. - induction l. - - simpl. congruence. - - intros until m2. intros EXEB1 EXEB2. - inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate. - simpl. rewrite EBI. eapply IHl; eauto. -Qed. - -Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}. - -Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}. -Next Obligation. - destruct tbb. simpl. auto. -Qed. - -Inductive exec_header: codestate -> codestate -> Prop := - | exec_header_cons: forall cs1, - exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1; - cur := cur cs1 |}. - -(* Theorem (A) in the diagram, the easiest of all *) -Theorem step_simu_header: - forall bb s fb sp c ms m rs1 m1 cs1, - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists cs1', - exec_header cs1 cs1' - /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1'). -Proof. - intros until cs1. intros Hpstate MCS. - eexists. split; eauto. - econstructor; eauto. - inv MCS. simpl in *. inv Hpstate. - econstructor; eauto. -Qed. - -Lemma step_matchasm_header: - forall fb cs1 cs1' s1, - match_asmstate fb cs1 s1 -> - exec_header cs1 cs1' -> - match_asmstate fb cs1' s1. -Proof. - intros until s1. intros MAS EXH. - inv MAS. inv EXH. - simpl. econstructor; eauto. -Qed. - -(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *) -Theorem step_simu_body: - forall bb s fb sp c ms m rs1 m1 ms' cs1 m', - MB.header bb = nil -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - body_step ge s fb sp (MB.body bb) ms m ms' m' -> - pstate cs1 = (State rs1 m1) -> - match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 -> - (exists rs2 m2 cs2 ep, - cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1; - pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |} - /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2 - /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2). -Proof. - intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy]. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. - inv BSTEP. - exists rs1, m1, cs1, (ep cs1). - inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto). - econstructor; eauto. - - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP. - rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'. - exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto. - intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS'). - simpl in *. - exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto. - intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS''). - exists rs3, m3, cs3, ep. - repeat (split; simpl; auto). subst. simpl in *. auto. - rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto. -Qed. - -Lemma exec_body_control: - forall b rs1 m1 rs2 m2 rs3 m3 fn, - exec_body tge (body b) rs1 m1 = Next rs2 m2 -> - exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 -> - exec_bblock_rel tge fn b rs1 m1 rs3 m3. -Proof. - intros until fn. intros EXEB EXECTL. - econstructor; eauto. inv EXECTL. - unfold exec_bblock. rewrite EXEB. auto. -Qed. - -Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat. - -Lemma mbsize_eqz: - forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None. -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H. - remember (length _) as a. remember (length_opt _) as b. - assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H. - inv H0. inv H1. destruct bdy; destruct ex; auto. - all: try discriminate. -Qed. - -Lemma mbsize_neqz: - forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None). -Proof. - intros. destruct bb as [hd bdy ex]; simpl in *. - destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate). - contradict H. unfold mbsize. simpl. auto. -Qed. - -(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *) -(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *) -Lemma step_simulation_bblock': - forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1, - bb' = mb_remove_header bb -> - body_step ge sf f sp (Machblock.body bb') rs m rs' m' -> - bb'' = mb_remove_body bb' -> - (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2. -Proof. - intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS. - destruct (mbsize bb) eqn:SIZE. - - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit). - destruct bb as [hd bdy ex]; simpl in *; subst. - inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc. - monadInv H2. simpl in *. inv ESTEP. inv BSTEP. - eexists. split. eapply plus_one. - exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'. - assert (x = tf) by congruence. subst x. - eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto. - unfold exec_bblock. simpl. eauto. - econstructor. eauto. eauto. eauto. - unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H. - assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - econstructor; eauto. - generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto. - eapply agree_exten; eauto. intros. Simpl. - intros. discriminate. - - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. } - intros Hnotempty. - - (* initial setting *) - exploit match_state_codestate. - 2: eapply Hnotempty. - all: eauto. - intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate). - - (* step_simu_header part *) - assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. } - destruct H as (rs1 & m1 & Hpstate2). subst. - assert (f = fb). { inv MCS. auto. } subst fb. - exploit step_simu_header. - 2: eapply MCS. - all: eauto. - intros (cs1' & EXEH & MCS2). - - (* step_simu_body part *) - assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. } - exploit step_simu_body. - 3: eapply BSTEP. - 4: eapply MCS2. - all: eauto. rewrite Hpstate'. eauto. - intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS'). - - (* step_simu_control part *) - assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)). - { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. } - destruct H as (tf & FIND'). - assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex). - { inv MAS. simpl in *. eauto. } - destruct H as (tex & Hpbody2 & Hpctl). - inv EXEH. simpl in *. - subst. exploit step_simu_control. - 9: eapply MCS'. all: simpl. - 10: eapply ESTEP. - all: simpl; eauto. - rewrite Hpbody2. rewrite Hpctl. - { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto. - erewrite exec_body_pc; eauto. } - intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS'). - - (* bringing the pieces together *) - exploit exec_body_trans. - eapply EXEB. - eauto. - intros EXEB2. - exploit exec_body_control; eauto. - rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto. - rewrite Hexit. rewrite Hpctl. eauto. - intros EXECB. inv EXECB. - exists (State rs4 m4). - split; auto. eapply plus_one. rewrite Hpstate2. - assert (exists ofs, rs1 PC = Vptr f ofs). - { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. } - destruct H0 as (ofs & Hrs1pc). - eapply exec_step_internal; eauto. - - (* proving the initial find_bblock *) - rewrite Hpstate2 in MAS. inv MAS. simpl in *. - assert (f1 = f0) by congruence. subst f0. - rewrite PCeq in Hrs1pc. inv Hrs1pc. - exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''. - inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. - eapply find_bblock_tail; eauto. -Qed. - -Theorem step_simulation_bblock: - forall sf f sp bb ms m ms' m' S2 c, - body_step ge sf f sp (Machblock.body bb) ms m ms' m' -> - (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> - exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'. -Proof. - intros until c. intros BSTEP Hbuiltin ESTEP S1' MS. - eapply step_simulation_bblock'; eauto. - all: destruct bb as [hd bdy ex]; simpl in *; eauto. - inv ESTEP. - - econstructor. inv H; try (econstructor; eauto; fail). - - econstructor. -Qed. - -(** Dealing now with the builtin case *) - -Definition split (c: MB.code) := - match c with - | nil => nil - | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |} - :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c - end. - -Lemma cons_ok_eq3 {A: Type} : - forall (x:A) y z x' y' z', - x = x' -> y = y' -> z = z' -> - OK (x::y::z) = OK (x'::y'::z'). -Proof. - intros. subst. auto. -Qed. - -Lemma transl_blocks_split_builtin: - forall bb c ep f ef args res, - MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil -> - transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep. -Proof. - intros until res. intros Hexit Hbody. simpl split. - unfold transl_blocks. fold transl_blocks. unfold transl_block. - simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi. - remember (transl_blocks _ _ _) as tlbs. - destruct tbc; destruct tbi; destruct tlbs. - all: try simpl; auto. - - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl. - unfold gen_bblocks. simpl. destruct l. - + exploit transl_basic_code_nonil; eauto. intro. destruct H. - + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto. -Qed. - -Lemma transl_code_at_pc_split_builtin: - forall rs f f0 bb c ep tf tc ef args res, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc -> - transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc. -Proof. - intros until res. intros Hbody Hexit AT. inv AT. - econstructor; eauto. erewrite transl_blocks_split_builtin; eauto. -Qed. - -Theorem match_states_split_builtin: - forall sf f sp bb c rs m ef args res S1, - MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - match_states (Machblock.State sf f sp (bb :: c) rs m) S1 -> - match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1. -Proof. - intros until S1. intros Hbody Hexit MS. - inv MS. - econstructor; eauto. - eapply transl_code_at_pc_split_builtin; eauto. -Qed. - -Theorem step_simulation_builtin: - forall ef args res bb sf f sp c ms m t S2, - MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) -> - exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 -> - forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' -> - exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'. -Proof. - intros until S2. intros Hbody Hexit ESTEP S1' MS. - inv MS. inv AT. monadInv H2. monadInv EQ. - rewrite Hbody in EQ0. monadInv EQ0. - rewrite Hexit in EQ. monadInv EQ. - rewrite Hexit in ESTEP. inv ESTEP. inv H4. - - exploit functions_transl; eauto. intro FN. - generalize (transf_function_no_overflow _ _ H1); intro NOOV. - exploit builtin_args_match; eauto. intros [vargs' [P Q]]. - exploit external_call_mem_extends; eauto. - intros [vres' [m2' [A [B [C D]]]]]. - econstructor; split. apply plus_one. - simpl in H3. - eapply exec_step_builtin. eauto. eauto. - eapply find_bblock_tail; eauto. - simpl. eauto. - erewrite <- sp_val by eauto. - eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - eauto. - econstructor; eauto. - instantiate (2 := tf); instantiate (1 := x0). - unfold nextblock, incrPC. rewrite Pregmap.gss. - rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence. - rewrite <- H. simpl. econstructor; eauto. - eapply code_tail_next_int; eauto. - rewrite preg_notin_charact. intros. auto with asmgen. - auto with asmgen. - apply agree_nextblock. eapply agree_set_res; auto. - eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto. - apply Pregmap.gso; auto with asmgen. - congruence. -Qed. - -Lemma next_sep: - forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - congruence. -Qed. - -(* Measure to prove finite stuttering, see the other backends *) -Definition measure (s: MB.state) : nat := - match s with - | MB.State _ _ _ _ _ _ => 0%nat - | MB.Callstate _ _ _ _ => 0%nat - | MB.Returnstate _ _ _ => 1%nat - end. - -(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs - for the internal and external function cases *) -Theorem step_simulation: - forall S1 t S2, MB.step return_address_offset ge S1 t S2 -> - forall S1' (MS: match_states S1 S1'), - (exists S2', plus step tge S1' t S2' /\ match_states S2 S2') - \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat. -Proof. - induction 1; intros. - -- (* bblock *) - left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0. - all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock; - try (rewrite MBE; try discriminate); eauto). - + (* MBbuiltin *) - destruct (MB.body bb) eqn:MBB. - * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto. - * eapply match_states_split_builtin in MS; eauto. - 2: rewrite MBB; discriminate. - simpl split in MS. - rewrite <- MBB in H. - remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1. - assert (MB.body bb = MB.body bb1). { subst. simpl. auto. } - rewrite H1 in H. subst. - exploit step_simulation_bblock. eapply H. - discriminate. - simpl. constructor. - eauto. - intros (S2' & PLUS1 & MS'). - rewrite MBE in MS'. - assert (exit_step return_address_offset ge (Some (MBbuiltin e l b)) - (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c) - rs' m') t s'). - { inv H0. inv H3. econstructor. econstructor; eauto. } - exploit step_simulation_builtin. - 4: eapply MS'. - all: simpl; eauto. - intros (S3' & PLUS'' & MS''). - exists S3'. split; eauto. - eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto. - + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto. - -- (* internal function *) - inv MS. - exploit functions_translated; eauto. intros [tf [A B]]. monadInv B. - generalize EQ; intros EQ'. monadInv EQ'. - destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0. - unfold Mach.store_stack in *. - exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl. - intros [m1' [C D]]. - exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto. - intros [m2' [F G]]. - simpl chunk_of_type in F. - exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto. - intros [m3' [P Q]]. - (* Execution of function prologue *) - monadInv EQ0. - set (tfbody := make_prologue f x0) in *. - set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *. - set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef). - exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto. - intros (rs' & U' & V'). - exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2'). - { rewrite chunk_of_Tptr in P. - assert (rs' GPRA = rs0 RA). { apply V'. } - assert (rs' SP = rs2 SP). { apply V'; discriminate. } - rewrite H4. rewrite H3. - rewrite ATLR. - change (rs2 SP) with sp. eexact P. } - intros (rs3 & U & V). - assert (EXEC_PROLOGUE: exists rs3', - exec_straight_blocks tge tf - tf.(fn_blocks) rs0 m' - x0 rs3' m3' - /\ forall r, r <> PC -> rs3' r = rs3 r). - { eexists. split. - - change (fn_blocks tf) with tfbody; unfold tfbody. - econstructor; eauto. unfold exec_bblock. simpl exec_body. - rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F. - Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset. - rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P. - simpl. apply next_sep; eauto. reflexivity. - - intros. destruct V' as (V'' & V'). destruct r. - + Simpl. - destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. } - Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. } - + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. - + contradiction. - } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3'). - exploit exec_straight_steps_2; eauto using functions_transl. - simpl fn_blocks. simpl fn_blocks in g. omega. constructor. - intros (ofs' & X & Y). - left; exists (State rs3' m3'); split. - eapply exec_straight_steps_1; eauto. - simpl fn_blocks. simpl fn_blocks in g. omega. - constructor. - econstructor; eauto. - rewrite X; econstructor; eauto. - apply agree_exten with rs2; eauto with asmgen. - unfold rs2. - apply agree_set_other; auto with asmgen. - apply agree_change_sp with (parent_sp s). - apply agree_undef_regs with rs0. auto. -Local Transparent destroyed_at_function_entry. - simpl; intros; Simpl. - unfold sp; congruence. - - intros. - assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. } - rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto. - assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. } - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - contradict H3; rewrite H3; unfold data_preg; auto. - intros. rewrite Heqrs3'. rewrite V by auto with asmgen. - assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. } - rewrite H4 by auto with asmgen. reflexivity. discriminate. - -- (* external function *) - inv MS. - exploit functions_translated; eauto. - intros [tf [A B]]. simpl in B. inv B. - exploit extcall_arguments_match; eauto. - intros [args' [C D]]. - exploit external_call_mem_extends; eauto. - intros [res' [m2' [P [Q [R S]]]]]. - left; econstructor; split. - apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - econstructor; eauto. - unfold loc_external_result. - apply agree_set_other; auto. - apply agree_set_pair; auto. - apply agree_undef_caller_save_regs; auto. - -- (* return *) - inv MS. - inv STACKS. simpl in *. - right. split. omega. split. auto. - rewrite <- ATPC in H5. - econstructor; eauto. congruence. -Qed. - -Lemma transf_initial_states: - forall st1, MB.initial_state prog st1 -> - exists st2, AB.initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inversion H. unfold ge0 in *. - econstructor; split. - econstructor. - eapply (Genv.init_mem_transf_partial TRANSF); eauto. - replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero) - with (Vptr fb Ptrofs.zero). - econstructor; eauto. - constructor. - apply Mem.extends_refl. - split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence. - intros. rewrite Mach.Regmap.gi. auto. - unfold Genv.symbol_address. - rewrite (match_program_main TRANSF). - rewrite symbols_preserved. - unfold ge; rewrite H1. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r. -Proof. - intros. inv H0. inv H. constructor. assumption. - compute in H1. inv H1. - generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto. -Qed. - -Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop := - Asmblockgenproof0.return_address_offset. - -Theorem transf_program_correct: - forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_star with (measure := measure). - - apply senv_preserved. - - eexact transf_initial_states. - - eexact transf_final_states. - - exact step_simulation. -Qed. - -End PRESERVATION. diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v deleted file mode 100644 index 74b9b62b..00000000 --- a/mppa_k1c/Asmblockgenproof1.v +++ /dev/null @@ -1,2499 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** * Proof of correctness for individual instructions *) - -Require Import Coqlib Errors Maps. -Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op Locations Machblock Conventions. -Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops. -Require Import Chunks. - -Import PArithCoercions. - -(** Decomposition of integer constants. *) - -Lemma make_immed32_sound: - forall n, - match make_immed32 n with - | Imm32_single imm => n = imm - end. -Proof. - intros; unfold make_immed32. set (lo := Int.sign_ext 12 n). - predSpec Int.eq Int.eq_spec n lo; auto. -Qed. - -Lemma make_immed64_sound: - forall n, - match make_immed64 n with - | Imm64_single imm => n = imm - end. -Proof. - intros; unfold make_immed64. set (lo := Int64.sign_ext 12 n). - predSpec Int64.eq Int64.eq_spec n lo. -- auto. -- set (m := Int64.sub n lo). - set (p := Int64.zero_ext 20 (Int64.shru m (Int64.repr 12))). - predSpec Int64.eq Int64.eq_spec n (Int64.add (Int64.sign_ext 32 (Int64.shl p (Int64.repr 12))) lo). - auto. - auto. -Qed. - - -(** Properties of registers *) - -Lemma ireg_of_not_RTMP: - forall m r, ireg_of m = OK r -> IR r <> IR RTMP. -Proof. - intros. erewrite <- ireg_of_eq; eauto with asmgen. -Qed. - -Lemma ireg_of_not_RTMP': - forall m r, ireg_of m = OK r -> r <> RTMP. -Proof. - intros. apply ireg_of_not_RTMP in H. congruence. -Qed. - -Hint Resolve ireg_of_not_RTMP ireg_of_not_RTMP': asmgen. - - -(** Useful simplification tactic *) - -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -(** * Correctness of RISC-V constructor functions *) - -Section CONSTRUCTORS. - -Variable ge: genv. -Variable fn: function. - -Lemma loadimm32_correct: - forall rd n k rs m, - exists rs', - exec_straight ge (loadimm32 rd n ::g k) rs m k rs' m - /\ rs'#rd = Vint n - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - unfold loadimm32; intros. generalize (make_immed32_sound n); intros E. - destruct (make_immed32 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - -Lemma loadimm64_correct: - forall rd n k rs m, - exists rs', - exec_straight ge (loadimm64 rd n ::g k) rs m k rs' m - /\ rs'#rd = Vlong n - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - unfold loadimm64; intros. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. - intros; Simpl. -Qed. - -Lemma opimm64_correct: - forall (op: arith_name_rrr) - (opi: arith_name_rri64) - (sem: val -> val -> val) m, - (forall d s1 s2 rs, - exec_basic_instr ge (op d s1 s2) rs m = Next ((rs#d <- (sem rs#s1 rs#s2))) m) -> - (forall d s n rs, - exec_basic_instr ge (opi d s n) rs m = Next ((rs#d <- (sem rs#s (Vlong n)))) m) -> - forall rd r1 n k rs, - r1 <> RTMP -> - exists rs', - exec_straight ge (opimm64 op opi rd r1 n ::g k) rs m k rs' m - /\ rs'#rd = sem rs#r1 (Vlong n) - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. unfold opimm64. generalize (make_immed64_sound n); intros E. - destruct (make_immed64 n). -- subst imm. econstructor; split. - apply exec_straight_one. rewrite H0. simpl; eauto. auto. - split. Simpl. intros; Simpl. -Qed. - -(** Add offset to pointer *) - -Lemma addptrofs_correct: - forall rd r1 n k rs m, - r1 <> RTMP -> - exists rs', - exec_straight ge (addptrofs rd r1 n ::g k) rs m k rs' m - /\ Val.lessdef (Val.offset_ptr rs#r1 n) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - unfold addptrofs; intros. - destruct (Ptrofs.eq_dec n Ptrofs.zero). -- subst n. econstructor; split. - apply exec_straight_one. simpl; eauto. auto. - split. Simpl. destruct (rs r1); simpl; auto. rewrite Ptrofs.add_zero; auto. - intros; Simpl. -- unfold addimm64. - exploit (opimm64_correct Paddl Paddil Val.addl); eauto. intros (rs' & A & B & C). - exists rs'; split. eexact A. split; auto. - rewrite B. destruct (rs r1); simpl; auto. - rewrite Ptrofs.of_int64_to_int64 by auto. auto. -Qed. - -Ltac ArgsInv := - repeat (match goal with - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args - | [ H: bind _ _ = OK _ |- _ ] => monadInv H - | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv - end); - subst; - repeat (match goal with - | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in * - | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in * - end). - -Inductive exec_straight_opt: list instruction -> regset -> mem -> list instruction -> regset -> mem -> Prop := - | exec_straight_opt_refl: forall c rs m, - exec_straight_opt c rs m c rs m - | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2, - exec_straight ge c1 rs1 m1 c2 rs2 m2 -> - exec_straight_opt c1 rs1 m1 c2 rs2 m2. - -Remark exec_straight_opt_right: - forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2, - exec_straight_opt c1 rs1 m1 c2 rs2 m2 -> - exec_straight ge c2 rs2 m2 c3 rs3 m3 -> - exec_straight ge c1 rs1 m1 c3 rs3 m3. -Proof. - destruct 1; intros. auto. eapply exec_straight_trans; eauto. -Qed. - -Lemma transl_comp_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmp_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_comp. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 rs # r2)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmp_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compi_correct: - forall cmp r1 n lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compi cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmp_bool cmp rs#r1 (Vint n) = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compi. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Signed) rs # r1 (Vint n))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmp_bool cmp rs#r1 (Vint n)) as cmpbool. - destruct cmp; simpl; - unfold Val.cmp; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compu_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (Val_cmpu_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_comp. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val_cmpu_bool cmp rs#r1 rs#r2) as cmpubool. - destruct cmp; simpl; unfold Val_cmpu; - rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compui_correct: - forall cmp r1 n lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compi cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> - exec_control ge fn (Some (PCtlFlow ((Pcb BTwnez RTMP lbl)))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compi. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_int (itest_for_cmp cmp Unsigned) rs # r1 (Vint n))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val_cmpu_bool cmp rs#r1 (Vint n)) as cmpubool. - destruct cmp; simpl; unfold Val_cmpu; - rewrite <- Heqcmpubool; destruct cmpubool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compl_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compl cmp Signed r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpl_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compl. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 rs # r2)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpl_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold compare_long, Val.cmpl; - rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compil_correct: - forall cmp r1 n lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compil cmp Signed r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpl_bool cmp rs#r1 (Vlong n) = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compil. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Signed) rs # r1 (Vlong n))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpl_bool cmp rs#r1 (Vlong n)) as cmpbool. - destruct cmp; simpl; - unfold compare_long, Val.cmpl; - rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma swap_comparison_cmpf_eq: - forall v1 v2 cmp, - (Val.cmpf cmp v1 v2) = (Val.cmpf (swap_comparison cmp) v2 v1). -Proof. - intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. - rewrite Float.cmp_swap. auto. -Qed. - -Lemma swap_comparison_cmpf_bool: - forall cmp ft v1 v2, - ftest_for_cmp cmp = Reversed ft -> - Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. -Proof. - intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. -Qed. - -Lemma transl_compf_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp_float64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpf_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. unfold transl_comp_float64. destruct (ftest_for_cmp cmp) eqn:FT. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold compare_float; - unfold Val.cmpf; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. - erewrite swap_comparison_cmpf_bool in Heqcmpbool; eauto. - destruct cmp; simpl; - unfold compare_float; - unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma cmpf_bool_ne_eq: - forall v1 v2, - Val.cmpf_bool Cne v1 v2 = option_map negb (Val.cmpf_bool Ceq v1 v2). -Proof. - intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. reflexivity. -Qed. - -Lemma cmpf_bool_ne_eq_rev: - forall v1 v2, - Val.cmpf_bool Ceq v1 v2 = option_map negb (Val.cmpf_bool Cne v1 v2). -Proof. - intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. -Qed. - -Lemma option_map_negb_negb: - forall v, - option_map negb (option_map negb v) = v. -Proof. - destruct v; simpl; auto. rewrite negb_involutive. reflexivity. -Qed. - -Lemma notbool_option_map_negb: - forall v, Val.notbool (Val.of_optbool v) = Val.of_optbool (option_map negb v). -Proof. - unfold Val.notbool. unfold Val.of_optbool. - destruct v; auto. destruct b; auto. -Qed. - -Lemma swap_comparison_cmpf_bool_notftest: - forall cmp ft v1 v2, - notftest_for_cmp cmp = Reversed ft -> - Val.cmpf_bool cmp v1 v2 = Val.cmpf_bool (swap_comparison cmp) v2 v1. -Proof. - intros. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. rewrite Float.cmp_swap. reflexivity. -Qed. - -Lemma transl_compnotf_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp_notfloat64 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2) = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. unfold transl_comp_notfloat64. destruct (notftest_for_cmp cmp) eqn:FT. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r1) (rs r2))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (option_map negb (Val.cmpf_bool cmp rs#r1 rs#r2)) as cmpbool. - destruct cmp; simpl; - unfold compare_float; - unfold Val.cmpf; simpl in FT; inversion FT. - * rewrite cmpf_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite cmpf_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_float _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_float ft (rs r2) (rs r1))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpf_bool cmp rs#r1 rs#r2) as cmpbool. - erewrite swap_comparison_cmpf_bool_notftest in Heqcmpbool; eauto. - destruct cmp; simpl; - unfold compare_float; - unfold Val.cmpf; simpl in FT; inversion FT; simpl in Heqcmpbool. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma swap_comparison_cmpfs_bool: - forall cmp ft v1 v2, - ftest_for_cmp cmp = Reversed ft -> - Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. -Proof. - intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. -Qed. - -Lemma transl_compfs_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp_float32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val.cmpfs_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. unfold transl_comp_float32. destruct (ftest_for_cmp cmp) eqn:FT. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold compare_single; - unfold Val.cmpfs; simpl in FT; inversion FT; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. - erewrite swap_comparison_cmpfs_bool in Heqcmpbool; eauto. - destruct cmp; simpl; - unfold compare_single; - unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma swap_comparison_cmpfs_bool_notftest: - forall cmp ft v1 v2, - notftest_for_cmp cmp = Reversed ft -> - Val.cmpfs_bool cmp v1 v2 = Val.cmpfs_bool (swap_comparison cmp) v2 v1. -Proof. - intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_swap. reflexivity. -Qed. - -Lemma cmpfs_bool_ne_eq: - forall v1 v2, - Val.cmpfs_bool Cne v1 v2 = option_map negb (Val.cmpfs_bool Ceq v1 v2). -Proof. - intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. reflexivity. -Qed. - -Lemma cmpfs_bool_ne_eq_rev: - forall v1 v2, - Val.cmpfs_bool Ceq v1 v2 = option_map negb (Val.cmpfs_bool Cne v1 v2). -Proof. - intros. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. rewrite Float32.cmp_ne_eq. simpl. rewrite negb_involutive. reflexivity. -Qed. - -Lemma transl_compnotfs_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_comp_notfloat32 cmp r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2) = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. unfold transl_comp_notfloat32. destruct (notftest_for_cmp cmp) eqn:FT. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r1) (rs r2))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (option_map negb (Val.cmpfs_bool cmp rs#r1 rs#r2)) as cmpbool. - destruct cmp; simpl; - unfold compare_single; - unfold Val.cmpfs; simpl in FT; inversion FT. - * rewrite cmpfs_bool_ne_eq; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite cmpfs_bool_ne_eq_rev. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. - * esplit. split. - - apply exec_straight_one; simpl; eauto. - - split. - + intros; Simpl. - + intros. remember (rs # RTMP <- (compare_single _ _ _)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_single ft (rs r2) (rs r1))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val.cmpfs_bool cmp rs#r1 rs#r2) as cmpbool. - erewrite swap_comparison_cmpfs_bool_notftest in Heqcmpbool; eauto. - destruct cmp; simpl; - unfold compare_single; - unfold Val.cmpfs; simpl in FT; inversion FT; simpl in Heqcmpbool. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - * rewrite notbool_option_map_negb. rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_complu_correct: - forall cmp r1 r2 lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compl cmp Unsigned r1 r2 lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 rs#r2 = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compl. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 rs # r2)). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val_cmplu_bool cmp rs#r1 rs#r2) as cmpbool. - destruct cmp; simpl; - unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_compilu_correct: - forall cmp r1 n lbl k rs m tbb b, - exists rs', - exec_straight ge (transl_compil cmp Unsigned r1 n lbl k) rs m (Pcb BTwnez RTMP lbl ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> - exec_control ge fn (Some (PCtlFlow (Pcb BTwnez RTMP lbl))) (nextblock tbb rs') m - = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. esplit. split. -- unfold transl_compil. apply exec_straight_one; simpl; eauto. -- split. - + intros; Simpl. - + intros. - remember (rs # RTMP <- (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))) as rs'. - simpl. assert (Val.cmp_bool Cne (nextblock tbb rs') # RTMP (Vint (Int.repr 0)) = Some b). - { - assert ((nextblock tbb rs') # RTMP = (compare_long (itest_for_cmp cmp Unsigned) rs # r1 (Vlong n))). - { rewrite Heqrs'. auto. } - rewrite H0. rewrite <- H. - remember (Val_cmplu_bool cmp rs#r1 (Vlong n)) as cmpbool. - destruct cmp; simpl; - unfold compare_long, Val_cmplu; rewrite <- Heqcmpbool; destruct cmpbool; simpl; auto; - destruct b0; simpl; auto. - } - rewrite H0. simpl; auto. -Qed. - -Lemma transl_opt_compuimm_correct: - forall n cmp r1 lbl k rs m b tbb c, - select_comp n cmp = Some c -> - exists rs', exists insn, - exec_straight_opt (transl_opt_compuimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmpu_bool cmp rs#r1 (Vint n) = Some b -> - exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. -(* unfold transl_opt_compuimm. unfold select_comp in H. rewrite H; simpl. *) - remember c as c'. - destruct c'. - - (* c = Ceq *) - assert (Int.eq n Int.zero = true) as H'. - { remember (Int.eq n Int.zero) as termz. destruct termz; auto. - generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int.repr 0)) as H0. { - destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. - generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. - rewrite H'. discriminate. - } - assert (Ceq = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - unfold transl_opt_compuimm. subst. rewrite H'. - - exists rs, (Pcbu BTweqz r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock, incrPC. Simpl. rewrite H1 in H0. - (*assert (Val.cmp_bool Ceq (rs r1) (Vint (Int.repr 0)) = Some b) as EVAL'S. - { rewrite <- H2. rewrite <- H0. rewrite <- H1. auto. }*) - auto; - unfold eval_branch. rewrite H0; auto. - - (* c = Cne *) - assert (Int.eq n Int.zero = true) as H'. - { remember (Int.eq n Int.zero) as termz. destruct termz; auto. - generalize H. unfold select_comp; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int.repr 0)) as H0. { - destruct (Int.eq_dec n (Int.repr 0)) as [Ha|Ha]; auto. - generalize (Int.eq_false _ _ Ha). unfold Int.zero in H'. - rewrite H'. discriminate. - } - assert (Cne = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_comp; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - unfold transl_opt_compuimm. subst. rewrite H'. - - exists rs, (Pcbu BTwnez r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock, incrPC. Simpl. rewrite H1 in H0. - auto; - unfold eval_branch. rewrite H0. auto. - - (* c = Clt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cle *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cgt *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. - - (* c = Cge *) contradict H; unfold select_comp; destruct (Int.eq n Int.zero); - destruct cmp; discriminate. -Qed. - -Lemma transl_opt_compluimm_correct: - forall n cmp r1 lbl k rs m b tbb c, - select_compl n cmp = Some c -> - exists rs', exists insn, - exec_straight_opt (transl_opt_compluimm n cmp r1 lbl k) rs m ((PControl insn) ::g k) rs' m - /\ (forall r : preg, r <> PC -> r <> RTMP -> rs' r = rs r) - /\ ( Val_cmplu_bool cmp rs#r1 (Vlong n) = Some b -> - exec_control ge fn (Some insn) (nextblock tbb rs') m = eval_branch fn lbl (nextblock tbb rs') m (Some b)) - . -Proof. - intros. -(* unfold transl_opt_compluimm; rewrite H; simpl. *) - remember c as c'. - destruct c'. - - (* c = Ceq *) - assert (Int64.eq n Int64.zero = true) as H'. - { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. - generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int64.repr 0)) as H0. { - destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. - generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. - rewrite H'. discriminate. - } - assert (Ceq = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - unfold transl_opt_compluimm; subst; rewrite H'. - - exists rs, (Pcbu BTdeqz r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock, incrPC. Simpl. rewrite H1 in H0. - auto; - unfold eval_branch. rewrite H0; auto. - - (* c = Cne *) - assert (Int64.eq n Int64.zero = true) as H'. - { remember (Int64.eq n Int64.zero) as termz. destruct termz; auto. - generalize H. unfold select_compl; rewrite <- Heqtermz; simpl. - discriminate. } - assert (n = (Int64.repr 0)) as H0. { - destruct (Int64.eq_dec n (Int64.repr 0)) as [Ha|Ha]; auto. - generalize (Int64.eq_false _ _ Ha). unfold Int64.zero in H'. - rewrite H'. discriminate. - } - assert (Cne = cmp). { - remember cmp as c0'. destruct c0'; auto; generalize H; unfold select_compl; - rewrite H'; simpl; auto; - intros; contradict H; discriminate. - } - unfold transl_opt_compluimm; subst; rewrite H'. - - exists rs, (Pcbu BTdnez r1 lbl). - split. - * constructor. - * split; auto. simpl. intros. - assert (rs r1 = (nextblock tbb rs) r1). - unfold nextblock, incrPC. Simpl. rewrite H1 in H0. - auto; - unfold eval_branch. rewrite H0; auto. - - (* c = Clt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cle *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cgt *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. - - (* c = Cge *) contradict H; unfold select_compl; destruct (Int64.eq n Int64.zero); - destruct cmp; discriminate. -Qed. - -Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core. - -Lemma transl_cbranch_correct_1: - forall cond args lbl k c m ms b sp rs m' tbb, - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some b -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', exists insn, - exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' - /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = eval_branch fn lbl (nextblock tbb rs') m' (Some b) - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until tbb; intros TRANSL EVAL AG MEXT. - set (vl' := map rs (map preg_of args)). - assert (EVAL': eval_condition cond vl' m' = Some b). - { apply eval_condition_lessdef with (map ms args) m; auto. eapply preg_vals; eauto. } - clear EVAL MEXT AG. - destruct cond; simpl in TRANSL; ArgsInv. -(* Ccomp *) -- exploit (transl_comp_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccompu *) -- exploit (transl_compu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; eauto. -(* Ccompimm *) -- remember (Int.eq n Int.zero) as eqz. - destruct eqz. - + assert (n = (Int.repr 0)). { - destruct (Int.eq_dec n (Int.repr 0)) as [H|H]; auto. - generalize (Int.eq_false _ _ H). unfold Int.zero in Heqeqz. - rewrite <- Heqeqz. discriminate. - } - exists rs, (Pcb (btest_for_cmpswz c0) x lbl). - split. - * constructor. - * split; auto. - assert (rs x = (nextblock tbb rs) x). - unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. - destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (transl_compi_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez RTMP lbl). - split. - * constructor. eexact A'. - * split; auto. - { apply C'; auto. } -(* Ccompuimm *) -- remember (select_comp n c0) as selcomp. - destruct selcomp. - + exploit (transl_opt_compuimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. - intros (rs' & i & A & B & C). - exists rs', i. - split. - * apply A. - * split; auto. apply C. apply EVAL'. - + assert (transl_opt_compuimm n c0 x lbl k = transl_compi c0 Unsigned x n lbl k). - { unfold transl_opt_compuimm. - destruct (Int.eq n Int.zero) eqn:EQN. - all: unfold select_comp in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. - all: discriminate. } - rewrite H. clear H. - exploit (transl_compui_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez RTMP lbl). - split. - * constructor. eexact A'. - * split; auto. - { apply C'; auto. } -(* Ccompl *) -- exploit (transl_compl_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -(* Ccomplu *) -- exploit (transl_complu_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; eauto. -(* Ccomplimm *) -- remember (Int64.eq n Int64.zero) as eqz. - destruct eqz. - + assert (n = (Int64.repr 0)). { - destruct (Int64.eq_dec n (Int64.repr 0)) as [H|H]; auto. - generalize (Int64.eq_false _ _ H). unfold Int64.zero in Heqeqz. - rewrite <- Heqeqz. discriminate. - } - exists rs, (Pcb (btest_for_cmpsdz c0) x lbl). - split. - * constructor. - * split; auto. - assert (rs x = (nextblock tbb rs) x). - unfold nextblock, incrPC. Simpl. rewrite H0 in EVAL'. clear H0. - destruct c0; simpl; auto; - unfold eval_branch; rewrite <- H; rewrite EVAL'; auto. - + exploit (transl_compil_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez RTMP lbl). - split. - * constructor. eexact A'. - * split; auto. - { apply C'; auto. } - -(* Ccompluimm *) -- remember (select_compl n c0) as selcomp. - destruct selcomp. - + exploit (transl_opt_compluimm_correct n c0 x lbl k). apply eq_sym. apply Heqselcomp. - intros (rs' & i & A & B & C). - exists rs', i. - split. - * apply A. - * split; eauto. (* apply C. apply EVAL'. *) - + assert (transl_opt_compluimm n c0 x lbl k = transl_compil c0 Unsigned x n lbl k). - { unfold transl_opt_compluimm. - destruct (Int64.eq n Int64.zero) eqn:EQN. - all: unfold select_compl in Heqselcomp; rewrite EQN in Heqselcomp; destruct c0; simpl in *; auto. - all: discriminate. } - rewrite H. clear H. - exploit (transl_compilu_correct c0 x n lbl); eauto. intros (rs'2 & A' & B' & C'). - exists rs'2, (Pcb BTwnez RTMP lbl). - split. - * constructor. eexact A'. - * split; auto. - { apply C'; auto. eapply Val_cmplu_bool_correct; eauto. } - -(* Ccompf *) -- exploit (transl_compf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. - -(* Cnotcompf *) -- exploit (transl_compnotf_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. - -(* Ccompfs *) -- exploit (transl_compfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. - -(* Cnotcompfs *) -- exploit (transl_compnotfs_correct c0 x x0 lbl); eauto. intros (rs' & A & B & C). - exists rs', (Pcb BTwnez RTMP lbl). - split. - + constructor. eexact A. - + split; auto. apply C; auto. -Qed. - -Lemma transl_cbranch_correct_true: - forall cond args lbl k c m ms sp rs m' tbb, - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some true -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', exists insn, - exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' - /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = goto_label fn lbl (nextblock tbb rs') m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. eapply transl_cbranch_correct_1 with (b := true); eauto. -Qed. - -Lemma transl_cbranch_correct_false: - forall cond args lbl k c m ms sp rs tbb m', - transl_cbranch cond args lbl k = OK c -> - eval_condition cond (List.map ms args) m = Some false -> - agree ms sp rs -> - Mem.extends m m' -> - exists rs', exists insn, - exec_straight_opt c rs m' ((PControl insn) ::g k) rs' m' - /\ exec_control ge fn (Some insn) (nextblock tbb rs') m' = Next (nextblock tbb rs') m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. exploit transl_cbranch_correct_1. all: eauto. simpl eval_branch. instantiate (1 := tbb). - intros (rs' & insn & A & B & C). rewrite regset_same_assign in B. - eexists; eexists. split; try split. all: eassumption. -Qed. - -(** Translation of condition operators *) - -Lemma transl_cond_int32s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_int32s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 rs#r2) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - - -Lemma transl_cond_int32u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_int32u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val_cmpu cmp rs#r1 rs#r2 - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_int64s_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_int64s cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 rs#r2)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_int64u_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_int64u cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ rs'#rd = Val_cmplu cmp rs#r1 rs#r2 - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int32s_correct: - forall cmp rd r1 n k rs m, - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code (transl_condimm_int32s cmp rd r1 n k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.cmp cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core. - -Lemma transl_condimm_int32u_correct: - forall cmp rd r1 n k rs m, - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code (transl_condimm_int32u cmp rd r1 n k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp rs#r1 (Vint n)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int64s_correct: - forall cmp rd r1 n k rs m, - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code (transl_condimm_int64s cmp rd r1 n k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.maketotal (Val.cmpl cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_condimm_int64u_correct: - forall cmp rd r1 n k rs m, - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code (transl_condimm_int64u cmp rd r1 n k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp rs#r1 (Vlong n))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl; - (econstructor; split; - [ apply exec_straight_one; [simpl; eauto] | - split; intros; Simpl; unfold compare_long; eauto]). -Qed. - -Lemma swap_comparison_cmpfs: - forall v1 v2 cmp, - Val.lessdef (Val.cmpfs cmp v1 v2) (Val.cmpfs (swap_comparison cmp) v2 v1). -Proof. - intros. unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct v1; destruct v2; auto. - rewrite Float32.cmp_swap. auto. -Qed. - -Lemma transl_cond_float32_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_float32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.cmpfs cmp rs#r1 rs#r2) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. apply swap_comparison_cmpfs. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. apply swap_comparison_cmpfs. -- econstructor; split. apply exec_straight_one; [simpl; - eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_nofloat32_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_notfloat32 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpfs_bool cmp (rs r1) (rs r2)))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. - rewrite Float32.cmp_ne_eq. auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. - rewrite Float32.cmp_ne_eq. simpl. destruct (Float32.cmp Ceq f f0); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - destruct (Float32.cmp Clt f f0); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float32.cmp_swap. - destruct (Float32.cmp _ _ _); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float32.cmp_swap. - destruct (Float32.cmp _ _ _); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpfs. unfold Val.cmpfs_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - destruct (Float32.cmp _ _ _); auto. -Qed. - -Lemma swap_comparison_cmpf: - forall v1 v2 cmp, - Val.lessdef (Val.cmpf cmp v1 v2) (Val.cmpf (swap_comparison cmp) v2 v1). -Proof. - intros. unfold Val.cmpf. unfold Val.cmpf_bool. destruct v1; destruct v2; auto. - rewrite Float.cmp_swap. auto. -Qed. - -Lemma transl_cond_float64_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_float64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.cmpf cmp rs#r1 rs#r2) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. apply swap_comparison_cmpf. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. apply swap_comparison_cmpf. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. -Qed. - -Lemma transl_cond_nofloat64_correct: - forall cmp rd r1 r2 k rs m, - exists rs', - exec_straight ge (basics_to_code (transl_cond_notfloat64 cmp rd r1 r2 k)) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.of_optbool (option_map negb (Val.cmpf_bool cmp (rs r1) (rs r2)))) rs'#rd - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros. destruct cmp; simpl. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. - rewrite Float.cmp_ne_eq. auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. - rewrite Float.cmp_ne_eq. simpl. destruct (Float.cmp Ceq f f0); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - destruct (Float.cmp Clt f f0); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Cge = swap_comparison Cle); auto. rewrite Float.cmp_swap. - destruct (Float.cmp _ _ _); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - cutrewrite (Clt = swap_comparison Cgt); auto. rewrite Float.cmp_swap. - destruct (Float.cmp _ _ _); auto. -- econstructor; split. apply exec_straight_one; [simpl; eauto]. - split; intros; Simpl. - unfold Val.cmpf. unfold Val.cmpf_bool. destruct (rs r1); auto. destruct (rs r2); auto. simpl. - destruct (Float.cmp _ _ _); auto. -Qed. - -Lemma transl_cond_op_correct: - forall cond rd args k c rs m, - transl_cond_op cond rd args k = OK c -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ Val.lessdef (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)) rs'#rd - /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r. -Proof. - assert (MKTOT: forall ob, Val.of_optbool ob = Val.maketotal (option_map Val.of_bool ob)). - { destruct ob as [[]|]; reflexivity. } - intros until m; intros TR. - destruct cond; simpl in TR; ArgsInv. -+ (* cmp *) - exploit transl_cond_int32s_correct; eauto. simpl. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpu *) - exploit transl_cond_int32u_correct; eauto. simpl. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B; eapply Val_cmpu_correct. -+ (* cmpimm *) - apply transl_condimm_int32s_correct; eauto with asmgen. -+ (* cmpuimm *) - apply transl_condimm_int32u_correct; eauto with asmgen. -+ (* cmpl *) - exploit transl_cond_int64s_correct; eauto. simpl. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmplu *) - exploit transl_cond_int64u_correct; eauto. simpl. intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite B, MKTOT; eauto. - eapply Val_cmplu_correct. -+ (* cmplimm *) - exploit transl_condimm_int64s_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpluimm *) - exploit transl_condimm_int64u_correct; eauto. instantiate (1 := x); eauto with asmgen. simpl. - intros (rs' & A & B & C). - exists rs'; repeat split; eauto. rewrite MKTOT; eauto. -+ (* cmpfloat *) - exploit transl_cond_float64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpnosingle *) - exploit transl_cond_nofloat64_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpsingle *) - exploit transl_cond_float32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -+ (* cmpnosingle *) - exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto. -Qed. - -(* Translation of arithmetic operations *) - -Ltac SimplEval H := - match type of H with - | Some _ = None _ => discriminate - | Some _ = Some _ => inv H - | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity) -end. - -Ltac TranslOpSimpl := - econstructor; split; - [ apply exec_straight_one; reflexivity - | split; [ apply Val.lessdef_same; simpl; Simpl; fail | intros; simpl; Simpl; fail ] ]. - -Lemma int_eq_comm: - forall (x y: int), - (Int.eq x y) = (Int.eq y x). -Proof. - intros. - unfold Int.eq. - unfold zeq. - destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. -Qed. - -Lemma int64_eq_comm: - forall (x y: int64), - (Int64.eq x y) = (Int64.eq y x). -Proof. - intros. - unfold Int64.eq. - unfold zeq. - destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence. -Qed. - -Lemma select_same_lessdef: - forall ty c v, - Val.lessdef (Val.select c v v ty) v. -Proof. - intros. - unfold Val.select. - destruct c; try econstructor. - replace (if b then v else v) with v by (destruct b ; trivial). - destruct v; destruct ty; simpl; econstructor. -Qed. - -Lemma if_neg : forall X, - forall a, - forall b c : X, - (if (negb a) then b else c) = (if a then c else b). -Proof. - destruct a; reflexivity. -Qed. - -Lemma int_ltu_to_neq: - forall x, - Int.ltu Int.zero x = negb (Int.eq x Int.zero). -Proof. - intros. - unfold Int.ltu, Int.eq. - change (Int.unsigned Int.zero) with 0. - pose proof (Int.unsigned_range x) as RANGE. - unfold zlt, zeq. - destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. -Qed. - -Lemma int64_ltu_to_neq: - forall x, - Int64.ltu Int64.zero x = negb (Int64.eq x Int64.zero). -Proof. - intros. - unfold Int64.ltu, Int64.eq. - change (Int64.unsigned Int64.zero) with 0. - pose proof (Int64.unsigned_range x) as RANGE. - unfold zlt, zeq. - destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega. -Qed. - -Ltac splitall := repeat match goal with |- _ /\ _ => split end. - -Lemma transl_op_correct: - forall op args res k (rs: regset) m v c, - transl_op op args res k = OK c -> - eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ Val.lessdef v rs'#(preg_of res) - /\ forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r. -Proof. - assert (SAME: forall v1 v2, v1 = v2 -> Val.lessdef v2 v1). { intros; subst; auto. } -Opaque Int.eq. - intros until c; intros TR EV. - unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl. -- (* Omove *) - destruct (preg_of res), (preg_of m0); inv TR; TranslOpSimpl. -- (* Oaddrsymbol *) - destruct (Archi.pic_code tt && negb (Ptrofs.eq ofs Ptrofs.zero)). -+ set (rs1 := (rs#x <- (Genv.symbol_address ge id Ptrofs.zero))). - exploit (addptrofs_correct x x ofs (basics_to_code k) rs1 m); eauto with asmgen. - intros (rs2 & A & B & C). - exists rs2; split. - apply exec_straight_step with rs1 m; auto. - split. replace ofs with (Ptrofs.add Ptrofs.zero ofs) by (apply Ptrofs.add_zero_l). - rewrite Genv.shift_symbol_address. - replace (rs1 x) with (Genv.symbol_address ge id Ptrofs.zero) in B by (unfold rs1; Simpl). - exact B. - intros. rewrite C by eauto with asmgen. unfold rs1; Simpl. -+ TranslOpSimpl. -- (* Oaddrstack *) - exploit addptrofs_correct. instantiate (1 := SP); auto with asmgen. intros (rs' & A & B & C). - exists rs'; split; eauto. auto with asmgen. -- (* Ocast8signed *) - econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. - repeat split; intros; simpl; Simpl. - assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. -- (* Ocast16signed *) - econstructor; split. - eapply exec_straight_two. simpl;eauto. simpl;eauto. - repeat split; intros; Simpl. - assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. - destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. -- (* Oshrximm *) - econstructor; split. - + apply exec_straight_one. simpl. eauto. - + repeat split. - * rewrite Pregmap.gss. - destruct (rs x0); simpl; trivial. - unfold Val.maketotal. - destruct (Int.ltu _ _); simpl; trivial. - * intros. - rewrite Pregmap.gso; trivial. -- (* Oshrxlimm *) - econstructor; split. - + apply exec_straight_one. simpl. eauto. - + repeat split. - * rewrite Pregmap.gss. - destruct (rs x0); simpl; trivial. - unfold Val.maketotal. - destruct (Int.ltu _ _); simpl; trivial. - * intros. - rewrite Pregmap.gso; trivial. - -- (* Ocmp *) - exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C). - exists rs'; repeat split; eauto with asmgen. - -- (* Osel *) - unfold conditional_move in *. - destruct (ireg_eq _ _). - { - subst x. inv EQ2. - econstructor; split. - { - apply exec_straight_one. - simpl. reflexivity. - } - split. - { apply select_same_lessdef. } - intros; trivial. - } - - destruct c0; simpl in *. - - all: destruct c. - all: simpl in *. - all: inv EQ2. - all: econstructor; splitall. - all: try apply exec_straight_one. - all: intros; simpl; trivial. - all: unfold Val.select, cmove, cmoveu; simpl. - all: destruct (rs x1); simpl; trivial. - all: try rewrite int_ltu_to_neq. - all: try rewrite int64_ltu_to_neq. - all: try change (Int64.eq Int64.zero Int64.zero) with true. - all: try destruct Archi.ptr64. - all: try rewrite Pregmap.gss. - all: repeat rewrite if_neg. - all: simpl. - all: try destruct (_ || _). - all: try apply Val.lessdef_normalize. - all: trivial. (* no more lessdef *) - all: apply Pregmap.gso; congruence. - -- (* Oselimm *) - unfold conditional_move_imm32 in *. - destruct c0; simpl in *. - - all: destruct c. - all: simpl in *. - all: inv EQ0. - all: econstructor; splitall. - all: try apply exec_straight_one. - all: intros; simpl; trivial. - all: unfold Val.select, cmove, cmoveu; simpl. - all: destruct (rs x0); simpl; trivial. - all: try rewrite int_ltu_to_neq. - all: try rewrite int64_ltu_to_neq. - all: try change (Int64.eq Int64.zero Int64.zero) with true. - all: try destruct Archi.ptr64. - all: try rewrite Pregmap.gss. - all: repeat rewrite if_neg. - all: simpl. - all: try destruct (_ || _). - all: try apply Val.lessdef_normalize. - all: trivial. (* no more lessdef *) - all: apply Pregmap.gso; congruence. - -- (* Osellimm *) - unfold conditional_move_imm64 in *. - destruct c0; simpl in *. - - all: destruct c. - all: simpl in *. - all: inv EQ0. - all: econstructor; splitall. - all: try apply exec_straight_one. - all: intros; simpl; trivial. - all: unfold Val.select, cmove, cmoveu; simpl. - all: destruct (rs x0); simpl; trivial. - all: try rewrite int_ltu_to_neq. - all: try rewrite int64_ltu_to_neq. - all: try change (Int64.eq Int64.zero Int64.zero) with true. - all: try destruct Archi.ptr64. - all: try rewrite Pregmap.gss. - all: repeat rewrite if_neg. - all: simpl. - all: try destruct (_ || _). - all: try apply Val.lessdef_normalize. - all: trivial. (* no more lessdef *) - all: apply Pregmap.gso; congruence. -Qed. - -(** Memory accesses *) - -Lemma indexed_memory_access_correct: - forall mk_instr base ofs k rs m, - exists base' ofs' rs' ptr', - exec_straight_opt (indexed_memory_access mk_instr base ofs ::g k) rs m - (mk_instr base' ofs' ::g k) rs' m - /\ eval_offset ofs' = OK ptr' - /\ Val.offset_ptr rs'#base' ptr' = Val.offset_ptr rs#base ofs - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - unfold indexed_memory_access; intros. - (* destruct Archi.ptr64 eqn:SF. *) - assert (Archi.ptr64 = true) as SF; auto. -- generalize (make_immed64_sound (Ptrofs.to_int64 ofs)); intros EQ. - destruct (make_immed64 (Ptrofs.to_int64 ofs)). -+ econstructor; econstructor; econstructor; econstructor; split. - apply exec_straight_opt_refl. - split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto. -Qed. - - -Lemma indexed_load_access_correct: - forall trap chunk (mk_instr: ireg -> offset -> basic) rd m, - (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> - forall (base: ireg) ofs k (rs: regset) v, - Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v -> - exists rs', - exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m - /\ rs'#rd = v - /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r. -Proof. - intros until m; intros EXEC; intros until v; intros LOAD. - exploit indexed_memory_access_correct; eauto. - intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. rewrite EXEC. - unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq. rewrite B, LOAD. eauto. Simpl. - split; intros; Simpl. auto. -Qed. - -Lemma indexed_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) r1 m, - (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> - forall (base: ireg) ofs k (rs: regset) m', - Mem.storev chunk m (Val.offset_ptr rs#base ofs) (rs#r1) = Some m' -> - exists rs', - exec_straight ge (indexed_memory_access mk_instr base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros until m; intros EXEC; intros until m'; intros STORE. - exploit indexed_memory_access_correct. (* instantiate (1 := base). eauto. *) - intros (base' & ofs' & rs' & ptr' & A & PtrEq & B & C). - econstructor; split. - eapply exec_straight_opt_right. eapply A. apply exec_straight_one. rewrite EXEC. - unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq. rewrite B, C, STORE. - eauto. - discriminate. - auto. -Qed. - -Lemma loadind_correct: - forall (base: ireg) ofs ty dst k c (rs: regset) m v, - loadind base ofs ty dst k = OK c -> - Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until v; intros TR LOAD. - assert (A: exists mk_instr rd, - preg_of dst = IR rd - /\ c = indexed_memory_access mk_instr base ofs :: k - /\ forall base' ofs' rs', - exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs'). - { unfold loadind in TR. - destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. } - destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq. - eapply indexed_load_access_correct; eauto with asmgen. -Qed. - -Lemma storeind_correct: - forall (base: ireg) ofs ty src k c (rs: regset) m m', - storeind src base ofs ty k = OK c -> - Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros until m'; intros TR STORE. - assert (A: exists mk_instr rr, - preg_of src = IR rr - /\ c = indexed_memory_access mk_instr base ofs :: k - /\ forall base' ofs' rs', - exec_basic_instr ge (mk_instr base' ofs') rs' m = - exec_store_offset (chunk_of_type ty) rs' m rr base' ofs'). - { unfold storeind in TR. destruct ty, (preg_of src); inv TR; econstructor; esplit; eauto. } - destruct A as (mk_instr & rr & rsEq & B & C). subst c. - eapply indexed_store_access_correct; eauto with asmgen. - congruence. -Qed. - -Ltac bsimpl := unfold exec_bblock; simpl. - -Lemma Pget_correct: - forall (dst: gpreg) (src: preg) k (rs: regset) m, - src = RA -> - exists rs', - exec_straight ge (Pget dst src ::g k) rs m k rs' m - /\ rs'#dst = rs#src - /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. -Proof. - intros. econstructor; econstructor; econstructor. -- rewrite H. bsimpl. auto. -- Simpl. -- intros. Simpl. -Qed. - -Lemma Pset_correct: - forall (dst: preg) (src: gpreg) k (rs: regset) m, - dst = RA -> - exists rs', - exec_straight ge (Pset dst src ::g k) rs m k rs' m - /\ rs'#dst = rs#src - /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. -Proof. - intros. econstructor; econstructor; econstructor; simpl. - rewrite H. auto. - Simpl. - Simpl. - intros. rewrite H. Simpl. -Qed. - -Lemma loadind_ptr_correct: - forall (base: ireg) ofs (dst: ireg) k (rs: regset) m v, - Mem.loadv Mptr m (Val.offset_ptr rs#base ofs) = Some v -> - exists rs', - exec_straight ge (loadind_ptr base ofs dst ::g k) rs m k rs' m - /\ rs'#dst = v - /\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r. -Proof. - intros. eapply indexed_load_access_correct; eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. - instantiate (1 := TRAP). - auto. -Qed. - -Lemma storeind_ptr_correct: - forall (base: ireg) ofs (src: ireg) k (rs: regset) m m', - Mem.storev Mptr m (Val.offset_ptr rs#base ofs) rs#src = Some m' -> - exists rs', - exec_straight ge (storeind_ptr src base ofs ::g k) rs m k rs' m' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. eapply indexed_store_access_correct with (r1 := src); eauto with asmgen. - intros. unfold Mptr. assert (Archi.ptr64 = true); auto. -Qed. - -Lemma transl_memory_access_correct: - forall mk_instr addr args k c (rs: regset) m v, - transl_memory_access mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - exists base ofs rs' ptr, - exec_straight_opt (basics_to_code c) rs m (mk_instr base ofs ::g (basics_to_code k)) rs' m - /\ eval_offset ofs = OK ptr - /\ Val.offset_ptr rs'#base ptr = v - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until v; intros TR EV. - unfold transl_memory_access in TR; destruct addr; ArgsInv. -- (* indexed *) - inv EV. exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). - eexists; eexists; eexists; eexists. split; try split; try split. - eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. - { intros. destruct r; rewrite RSEQ; auto. } -- (* global *) - simpl in EV. inv EV. inv TR. econstructor; econstructor; econstructor; econstructor; split. - constructor. apply exec_straight_one. simpl; eauto. auto. - split; split; intros; Simpl. - assert (Val.lessdef (Val.offset_ptr (Genv.symbol_address ge i i0) Ptrofs.zero) (Genv.symbol_address ge i i0)). - { apply Val.offset_ptr_zero. } - remember (Genv.symbol_address ge i i0) as symbol. - destruct symbol; auto. - + contradict Heqsymbol; unfold Genv.symbol_address. - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + contradict Heqsymbol; unfold Genv.symbol_address; - destruct (Genv.find_symbol ge i); discriminate. - + simpl. rewrite Ptrofs.add_zero; auto. -- (* stack *) - inv TR. inv EV. - exploit indexed_memory_access_correct; eauto. intros (base' & ofs' & rs' & ptr' & EOPT & EVALOFF & VALOFF & RSEQ). - eexists; eexists; eexists; eexists. split; try split; try split. - eapply EOPT. unfold eval_offset in EVALOFF. inv EVALOFF. eauto. - { intros. destruct r; rewrite RSEQ; auto. } -Qed. - -Lemma transl_memory_access2_correct: - forall mk_instr addr args k c (rs: regset) m v, - transl_memory_access2 mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - exists base ro mro mr1 rs', - args = mr1 :: mro :: nil - /\ ireg_of mro = OK ro - /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m - /\ Val.addl rs'#base rs'#ro = v - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until v; intros TR EV. - unfold transl_memory_access2 in TR; destruct addr; ArgsInv. - inv EV. repeat eexists. eassumption. econstructor; eauto. -Qed. - -Lemma transl_memory_access2XS_correct: - forall chunk mk_instr (scale : Z) args k c (rs: regset) m v, - transl_memory_access2XS chunk mk_instr scale args k = OK c -> - eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> - exists base ro mro mr1 rs', - args = mr1 :: mro :: nil - /\ ireg_of mro = OK ro - /\ exec_straight_opt (basics_to_code c) rs m (mk_instr base ro ::g (basics_to_code k)) rs' m - /\ Val.addl rs'#base (Val.shll rs'#ro (Vint (Int.repr scale))) = v - /\ (forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r) - /\ scale = (zscale_of_chunk chunk). -Proof. - intros until v; intros TR EV. - unfold transl_memory_access2XS in TR; ArgsInv. - inv EV. repeat eexists. eassumption. econstructor; eauto. - symmetry. - apply Z.eqb_eq. - assumption. -Qed. - -Lemma transl_load_access2_correct: - forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v', - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) -> - transl_memory_access2 mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = Some v' -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until v'; intros ARGS IREGE INSTR TR EV LOAD. - exploit transl_memory_access2_correct; eauto. - intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. -Qed. - -Lemma transl_load_access2_correct_notrap2: - forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro, - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) -> - transl_memory_access2 mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = None -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = concrete_default_notrap_load_value chunk - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until ro; intros ARGS IREGE INSTR TR EV LOAD. - exploit transl_memory_access2_correct; eauto. - intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. -Qed. - -Lemma transl_load_access2XS_correct: - forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v', - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) -> - transl_memory_access2XS chunk mk_instr scale args k = OK c -> - eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = Some v' -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until v'; intros ARGS IREGE INSTR TR EV LOAD. - exploit transl_memory_access2XS_correct; eauto. - intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. - unfold scale_of_chunk. - subst scale. - rewrite B, LOAD. reflexivity. Simpl. - split. trivial. intros. Simpl. -Qed. - -Lemma transl_load_access2XS_correct_notrap2: - forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro, - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) -> - transl_memory_access2XS chunk mk_instr scale args k = OK c -> - eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = None -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = concrete_default_notrap_load_value chunk - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until ro; intros ARGS IREGE INSTR TR EV LOAD. - exploit transl_memory_access2XS_correct; eauto. - intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs. - unfold scale_of_chunk. - subst scale. - rewrite B, LOAD. reflexivity. Simpl. - split. trivial. intros. Simpl. -Qed. - -Lemma transl_load_access_correct: - forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v', - (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) -> - transl_memory_access mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = Some v' -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = v' - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until v'; intros INSTR TR EV LOAD. - exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & ptr & A & PtrEq & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. - split; intros; Simpl. auto. -Qed. - -Lemma transl_load_access_correct_notrap2: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v, - (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) -> - transl_memory_access mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.loadv chunk m v = None -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#rd = concrete_default_notrap_load_value chunk - /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r. -Proof. - intros until v; intros INSTR TR EV LOAD. - exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & ptr & A & PtrEq & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl. - split. trivial. intros. Simpl. -Qed. - -Lemma transl_load_memory_access_ok: - forall addr trap chunk args dst k c rs a v m, - (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_load trap chunk addr args dst k = OK c -> - eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists mk_instr rd, - preg_of dst = IR rd - /\ transl_memory_access mk_instr addr args k = OK c - /\ forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs. -Proof. - intros until m. intros ADDR TR ? ?. - unfold transl_load in TR. destruct addr; try contradiction. - - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). - - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity - | eauto ]. - - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity - | eauto ]. -Qed. - -Lemma transl_load_memory_access_ok_notrap2: - forall addr chunk args dst k c rs a m, - (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_load NOTRAP chunk addr args dst k = OK c -> - eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = None -> - exists mk_instr rd, - preg_of dst = IR rd - /\ transl_memory_access mk_instr addr args k = OK c - /\ forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs. -Proof. - intros until m. intros ADDR TR ? ?. - unfold transl_load in TR. destruct addr; try contradiction. - - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto). - - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity - | eauto ]. - - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split; - [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity - | eauto ]. -Qed. - -Lemma transl_load_memory_access2_ok: - forall trap chunk args dst k c rs a v m, - transl_load trap chunk Aindexed2 args dst k = OK c -> - eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists mk_instr mr0 mro rd ro, - args = mr0 :: mro :: nil - /\ preg_of dst = IR rd - /\ preg_of mro = IR ro - /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c - /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro. -Proof. - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: - unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity - | eauto]. -Qed. - - -Lemma transl_load_memory_access2_ok_notrap2: - forall chunk args dst k c rs a m, - transl_load NOTRAP chunk Aindexed2 args dst k = OK c -> - eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = None -> - exists mk_instr mr0 mro rd ro, - args = mr0 :: mro :: nil - /\ preg_of dst = IR rd - /\ preg_of mro = IR ro - /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c - /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro. -Proof. - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: - unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity - | eauto]. -Qed. - -Lemma transl_load_memory_access2XS_ok: - forall scale trap chunk args dst k c rs a v m, - transl_load trap chunk (Aindexed2XS scale) args dst k = OK c -> - eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists mk_instr mr0 mro rd ro, - args = mr0 :: mro :: nil - /\ preg_of dst = IR rd - /\ preg_of mro = IR ro - /\ transl_memory_access2XS chunk mk_instr scale args k = OK c - /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro. -Proof. - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: - unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto - | eauto]. -Qed. - - -Lemma transl_load_memory_access2XS_ok_notrap2: - forall scale chunk args dst k c rs a m, - transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c -> - eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = None -> - exists mk_instr mr0 mro rd ro, - args = mr0 :: mro :: nil - /\ preg_of dst = IR rd - /\ preg_of mro = IR ro - /\ transl_memory_access2XS chunk mk_instr scale args k = OK c - /\ forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro. -Proof. - intros until m. intros TR ? ?. - unfold transl_load in TR. subst. monadInv TR. destruct chunk. all: - unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity - | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto - | eauto]. -Qed. - -Lemma transl_load_correct: - forall trap chunk addr args dst k c (rs: regset) m a v, - transl_load trap chunk addr args dst k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = Some v -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until v; intros TR EV LOAD. destruct addr. - - exploit transl_load_memory_access2XS_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access2_ok; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. - - exploit transl_load_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct; eauto with asmgen. -Qed. - -Lemma transl_load_correct_notrap2: - forall chunk addr args dst k c (rs: regset) m a, - transl_load NOTRAP chunk addr args dst k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.loadv chunk m a = None -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m - /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk) - /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros until a; intros TR EV LOAD. destruct addr. - - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C). - rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. - - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct_notrap2; eauto with asmgen. - - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct_notrap2; eauto with asmgen. - - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity). - intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq; - eapply transl_load_access_correct_notrap2; eauto with asmgen. -Qed. - -Lemma transl_store_access2_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m', - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk rs m r1 base ro) -> - transl_memory_access2 mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.storev chunk m v rs#r1 = Some m' -> - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. - exploit transl_memory_access2_correct; eauto. - intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_store_reg. unfold parexec_store_reg. rewrite B. rewrite C; try discriminate. rewrite STORE. auto. - intro. inv H. contradiction. - auto. -Qed. - -Lemma transl_store_access2XS_correct: - forall chunk (mk_instr: ireg -> ireg -> basic) scale args k c r1 (rs: regset) m v mr1 mro ro m', - args = mr1 :: mro :: nil -> - ireg_of mro = OK ro -> - (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_store_regxs chunk rs m r1 base ro) -> - transl_memory_access2XS chunk mk_instr scale args k = OK c -> - eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v -> - Mem.storev chunk m v rs#r1 = Some m' -> - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until m'; intros ARGS IREG INSTR TR EV STORE NOT31. - exploit transl_memory_access2XS_correct; eauto. - intros (base & ro2 & mr2 & mro2 & rs' & ARGSS & IREGG & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mro2 mr2. clear ARGS. - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2. - rewrite INSTR. unfold exec_store_regxs. unfold parexec_store_regxs. - unfold scale_of_chunk. - subst scale. - rewrite B. rewrite C; try discriminate. rewrite STORE. auto. - intro. inv H. contradiction. - auto. -Qed. - -Lemma transl_store_access_correct: - forall chunk (mk_instr: ireg -> offset -> basic) addr args k c r1 (rs: regset) m v m', - (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk rs m r1 base ofs) -> - transl_memory_access mk_instr addr args k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v -> - Mem.storev chunk m v rs#r1 = Some m' -> - r1 <> RTMP -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until m'; intros INSTR TR EV STORE NOT31. - exploit transl_memory_access_correct; eauto. - intros (base & ofs & rs' & ptr & A & PtrEq & B & C). - econstructor; split. - eapply exec_straight_opt_right. eexact A. apply exec_straight_one. - rewrite INSTR. unfold exec_store_offset. unfold parexec_store_offset. rewrite PtrEq, B. rewrite C; try discriminate. rewrite STORE. auto. - intro. inv H. contradiction. - auto. -Qed. - - -Remark exec_store_offset_8_sign rs m x base ofs: - exec_store_offset Mint8unsigned rs m x base ofs = exec_store_offset Mint8signed rs m x base ofs. -Proof. - unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. - destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_8. reflexivity. -Qed. - -Remark exec_store_offset_16_sign rs m x base ofs: - exec_store_offset Mint16unsigned rs m x base ofs = exec_store_offset Mint16signed rs m x base ofs. -Proof. - unfold exec_store_offset. unfold parexec_store_offset. unfold eval_offset; auto. unfold Mem.storev. - destruct (Val.offset_ptr _ _); auto. erewrite <- Mem.store_signed_unsigned_16. reflexivity. -Qed. - -Lemma transl_store_memory_access_ok: - forall addr chunk args src k c rs a m m', - (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) -> - transl_store chunk addr args src k = OK c -> - eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a (rs (preg_of src)) = Some m' -> - exists mk_instr chunk' rr, - preg_of src = IR rr - /\ transl_memory_access mk_instr addr args k = OK c - /\ (forall base ofs rs, - exec_basic_instr ge (mk_instr base ofs) rs m = exec_store_offset chunk' rs m rr base ofs) - /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). -Proof. - intros until m'. intros ? TR ? ?. - unfold transl_store in TR. destruct addr; try contradiction. - - monadInv TR. destruct chunk. all: - ArgsInv; eexists; eexists; eexists; split; try split; [ - repeat (destruct args; try discriminate); eassumption - | split; eauto; intros; simpl; try reflexivity]. - eapply exec_store_offset_8_sign. - eapply exec_store_offset_16_sign. - - monadInv TR. destruct chunk. all: - ArgsInv; eexists; eexists; eexists; split; try split; - [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption - | split; eauto; intros; simpl; try reflexivity]. - eapply exec_store_offset_8_sign. - eapply exec_store_offset_16_sign. - - monadInv TR. destruct chunk. all: - ArgsInv; eexists; eexists; eexists; split; try split; - [ repeat (destruct args; try discriminate); instantiate (1 := PStoreRRO _ x); simpl; eassumption - | split; eauto; intros; simpl; try reflexivity]. - eapply exec_store_offset_8_sign. - eapply exec_store_offset_16_sign. -Qed. - -Remark exec_store_reg_8_sign rs m x base ofs: - exec_store_reg Mint8unsigned rs m x base ofs = exec_store_reg Mint8signed rs m x base ofs. -Proof. - unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. - erewrite <- Mem.store_signed_unsigned_8. reflexivity. -Qed. - -Remark exec_store_reg_16_sign rs m x base ofs: - exec_store_reg Mint16unsigned rs m x base ofs = exec_store_reg Mint16signed rs m x base ofs. -Proof. - unfold exec_store_reg. unfold parexec_store_reg. unfold Mem.storev. destruct (Val.addl _ _); auto. - erewrite <- Mem.store_signed_unsigned_16. reflexivity. -Qed. - -Remark exec_store_regxs_8_sign rs m x base ofs: - exec_store_regxs Mint8unsigned rs m x base ofs = exec_store_regxs Mint8signed rs m x base ofs. -Proof. - unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. - erewrite <- Mem.store_signed_unsigned_8. reflexivity. -Qed. - -Remark exec_store_regxs_16_sign rs m x base ofs: - exec_store_regxs Mint16unsigned rs m x base ofs = exec_store_regxs Mint16signed rs m x base ofs. -Proof. - unfold exec_store_regxs. unfold parexec_store_regxs. unfold Mem.storev. destruct (Val.addl _ _); auto. - erewrite <- Mem.store_signed_unsigned_16. reflexivity. -Qed. - -Lemma transl_store_memory_access2_ok: - forall addr chunk args src k c rs a m m', - addr = Aindexed2 -> - transl_store chunk addr args src k = OK c -> - eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a (rs (preg_of src)) = Some m' -> - exists mk_instr chunk' rr mr0 mro ro, - args = mr0 :: mro :: nil - /\ preg_of mro = IR ro - /\ preg_of src = IR rr - /\ transl_memory_access2 mk_instr addr args k = OK c - /\ (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_store_reg chunk' rs m rr base ro) - /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). -Proof. - intros until m'. intros ? TR ? ?. - unfold transl_store in TR. subst addr. monadInv TR. destruct chunk. all: - unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ ArgsInv; reflexivity - | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRR _ x)); simpl; reflexivity - | eauto ]. - - simpl. intros. eapply exec_store_reg_8_sign. - - simpl. intros. eapply exec_store_reg_16_sign. -Qed. - -Lemma transl_store_memory_access2XS_ok: - forall scale chunk args src k c rs a m m', - transl_store chunk (Aindexed2XS scale) args src k = OK c -> - eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a (rs (preg_of src)) = Some m' -> - exists mk_instr chunk' rr mr0 mro ro, - args = mr0 :: mro :: nil - /\ preg_of mro = IR ro - /\ preg_of src = IR rr - /\ transl_memory_access2XS chunk' mk_instr scale args k = OK c - /\ (forall base rs, - exec_basic_instr ge (mk_instr base ro) rs m = exec_store_regxs chunk' rs m rr base ro) - /\ Mem.storev chunk m a rs#(preg_of src) = Mem.storev chunk' m a rs#(preg_of src). -Proof. - intros until m'. intros TR ? ?. - unfold transl_store in TR. monadInv TR. destruct chunk. all: - unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists; - [ ArgsInv; reflexivity - | rewrite EQ1; rewrite EQ0; instantiate (1 := (PStoreRRRXS _ x)); simpl; rewrite Heqb; eauto - | eauto ]. - - simpl. intros. eapply exec_store_regxs_8_sign. - - simpl. intros. eapply exec_store_regxs_16_sign. -Qed. - -Lemma transl_store_correct: - forall chunk addr args src k c (rs: regset) m a m', - transl_store chunk addr args src k = OK c -> - eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a -> - Mem.storev chunk m a rs#(preg_of src) = Some m' -> - exists rs', - exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m' - /\ forall r, r <> PC -> r <> RTMP -> rs'#r = rs#r. -Proof. - intros until m'; intros TR EV STORE. destruct addr. - - exploit transl_store_memory_access2XS_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). - eapply transl_store_access2XS_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. - destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. - - exploit transl_store_memory_access2_ok; eauto. intros (mk_instr & chunk' & rr & mr0 & mro & ro & argsEq & roEq & srcEq & A & B & C). - eapply transl_store_access2_correct; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity. congruence. - destruct rr; try discriminate. destruct src; simpl in srcEq; try discriminate. - - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intro A; - destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); - rewrite D in STORE; clear D; - eapply transl_store_access_correct; eauto with asmgen; try congruence; - destruct rr; try discriminate; destruct src; try discriminate. - - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intro A; - destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); - rewrite D in STORE; clear D; - eapply transl_store_access_correct; eauto with asmgen; try congruence; - destruct rr; try discriminate; destruct src; try discriminate. - - exploit transl_store_memory_access_ok; eauto; try discriminate; try (simpl; reflexivity). - intro A; - destruct A as (mk_instr & chunk' & rr & rrEq & B & C & D); - rewrite D in STORE; clear D; - eapply transl_store_access_correct; eauto with asmgen; try congruence; - destruct rr; try discriminate; destruct src; try discriminate. -Qed. - -Lemma make_epilogue_correct: - forall ge0 f m stk soff cs m' ms rs k tm, - Mach.load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) -> - Mach.load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - agree ms (Vptr stk soff) rs -> - Mem.extends m tm -> - match_stack ge0 cs -> - exists rs', exists tm', - exec_straight ge (make_epilogue f k) rs tm k rs' tm' - /\ agree ms (parent_sp cs) rs' - /\ Mem.extends m' tm' - /\ rs'#RA = parent_ra cs - /\ rs'#SP = parent_sp cs - /\ (forall r, r <> PC -> r <> RA -> r <> SP -> r <> RTMP -> r <> GPRA -> rs'#r = rs#r). -Proof. - intros until tm; intros LP LRA FREE AG MEXT MCS. - exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP'). - exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA'). - exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'. - exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'. - exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT'). - unfold make_epilogue. - rewrite chunk_of_Tptr in *. - - exploit ((loadind_ptr_correct SP (fn_retaddr_ofs f) GPRA (Pset RA GPRA ::g Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k)) - rs tm). - - rewrite <- (sp_val _ _ rs AG). simpl. eexact LRA'. - - intros (rs1 & A1 & B1 & C1). - assert (agree ms (Vptr stk soff) rs1) as AG1. - + destruct AG. - apply mkagree; auto. - rewrite C1; discriminate || auto. - intro. rewrite C1; auto; destruct r; simpl; try discriminate. - + exploit (Pset_correct RA GPRA (Pfreeframe (fn_stacksize f) (fn_link_ofs f) ::g k) rs1 tm). auto. - intros (rs2 & A2 & B2 & C2). - econstructor; econstructor; split. - * eapply exec_straight_trans. - { eexact A1. } - { eapply exec_straight_trans. - { eapply A2. } - { apply exec_straight_one. simpl. - rewrite (C2 SP) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'. - rewrite FREE'. eauto. } } - * split. apply agree_set_other; auto with asmgen. - apply agree_change_sp with (Vptr stk soff). - apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen. - eapply parent_sp_def; eauto. - split. auto. - split. Simpl. rewrite B2. auto. - split. Simpl. - intros. Simpl. - rewrite C2; auto. -Qed. - -End CONSTRUCTORS. - - diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v deleted file mode 100644 index bc14b231..00000000 --- a/mppa_k1c/Asmblockprops.v +++ /dev/null @@ -1,357 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Common definition and proofs on Asmblock required by various modules *) - -Require Import Coqlib. -Require Import Integers. -Require Import Memory. -Require Import Globalenvs. -Require Import Values. -Require Import Asmblock. -Require Import Axioms. - -Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) := - forall rs m, - exec_bblock ge f bb rs m <> Stuck -> - exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m. - -Hint Extern 2 (_ <> _) => congruence: asmgen. - -Lemma preg_of_data: - forall r, data_preg (preg_of r) = true. -Proof. - intros. destruct r; reflexivity. -Qed. -Hint Resolve preg_of_data: asmgen. - -Lemma data_diff: - forall r r', - data_preg r = true -> data_preg r' = false -> r <> r'. -Proof. - congruence. -Qed. -Hint Resolve data_diff: asmgen. - -Lemma preg_of_not_PC: - forall r, preg_of r <> PC. -Proof. - intros. apply data_diff; auto with asmgen. -Qed. - -Lemma preg_of_not_SP: - forall r, preg_of r <> SP. -Proof. - intros. unfold preg_of; destruct r; simpl; congruence. -Qed. - -Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen. - - -Lemma nextblock_pc: - forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)). -Proof. - intros. apply Pregmap.gss. -Qed. - -Lemma nextblock_inv: - forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r. -Proof. - intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto. -Qed. - -Lemma nextblock_inv1: - forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r. -Proof. - intros. apply nextblock_inv. red; intro; subst; discriminate. -Qed. - -Ltac Simplif := - ((rewrite nextblock_inv by eauto with asmgen) - || (rewrite nextblock_inv1 by eauto with asmgen) - || (rewrite Pregmap.gss) - || (rewrite nextblock_pc) - || (rewrite Pregmap.gso by eauto with asmgen) - ); auto with asmgen. - -Ltac Simpl := repeat Simplif. - -(* For Asmblockgenproof0 *) - -Theorem exec_basic_instr_pc: - forall ge b rs1 m1 rs2 m2, - exec_basic_instr ge b rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - intros. destruct b; try destruct i; try destruct i. - all: try (inv H; Simpl). - 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail. - - { (* PLoadQRRO *) - unfold parexec_load_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - { (* PLoadORRO *) - unfold parexec_load_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - destruct (Mem.loadv _ _ _) in H1; try discriminate. - inv H1. Simpl. } - 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail. - 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail. - - { (* PStoreQRRO *) - unfold parexec_store_q_offset in H1. - destruct (gpreg_q_expand _) as [r0 r1] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - { (* PStoreORRO *) - unfold parexec_store_o_offset in H1. - destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1. - unfold eval_offset in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - destruct (Mem.storev _ _ _) in H1; try discriminate. - inv H1. Simpl. reflexivity. } - - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate. - - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate. - destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate. - - destruct rs; try discriminate. inv H1. Simpl. - - destruct rd; try discriminate. inv H1; Simpl. - - reflexivity. -Qed. - -(* For PostpassSchedulingproof *) - -Lemma regset_double_set: - forall r1 r2 (rs: regset) v1 v2, - r1 <> r2 -> - (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1). -Proof. - intros. apply functional_extensionality. intros r. destruct (preg_eq r r1). - - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto. - - destruct (preg_eq r r2). - + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto. - + repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma next_eq: - forall (rs rs': regset) m m', - rs = rs' -> m = m' -> Next rs m = Next rs' m'. -Proof. - intros; apply f_equal2; auto. -Qed. - -Lemma exec_load_offset_pc_var: - forall trap t rs m rd ra ofs rs' m' v, - exec_load_offset trap t rs m rd ra ofs = Next rs' m' -> - exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_reg_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_reg trap t rs m rd ra ro = Next rs' m' -> - exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_regxs_pc_var: - forall trap t rs m rd ra ro rs' m' v, - exec_load_regxs trap t rs m rd ra ro = Next rs' m' -> - exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _). - - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. - - unfold parexec_incorrect_load in *. - destruct trap; try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate. -Qed. - -Lemma exec_load_offset_q_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_q_offset rs m rd ra ofs = Next rs' m' -> - exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *. - destruct (gpreg_q_expand rd) as [rd0 rd1]. - (* destruct (ireg_eq rd0 ra); try discriminate. *) - rewrite Pregmap.gso; try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - inv H. - destruct (Mem.loadv _ _ _); try discriminate. - inv H1. f_equal. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - reflexivity. -Qed. - -Lemma exec_load_offset_o_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_load_o_offset rs m rd ra ofs = Next rs' m' -> - exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *. - destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]. -(* - destruct (ireg_eq rd0 ra); try discriminate. - destruct (ireg_eq rd1 ra); try discriminate. - destruct (ireg_eq rd2 ra); try discriminate. -*) - rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - destruct (Mem.loadv _ _ _); try discriminate. - rewrite (regset_double_set PC rd0) by discriminate. - rewrite (regset_double_set PC rd1) by discriminate. - rewrite (regset_double_set PC rd2) by discriminate. - rewrite (regset_double_set PC rd3) by discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_offset_pc_var: - forall t rs m rd ra ofs rs' m' v, - exec_store_offset t rs m rd ra ofs = Next rs' m' -> - exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate. - destruct (eval_offset ofs); try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_q_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_q_offset rs m rd ra ofs = Next rs' m' -> - exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate. - simpl in *. - destruct (gpreg_q_expand _) as [s0 s1]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. apply next_eq; auto. -Qed. - -Lemma exec_store_o_offset_pc_var: - forall rs m rd ra ofs rs' m' v, - exec_store_o_offset rs m rd ra ofs = Next rs' m' -> - exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'. -Proof. - intros. - unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *. - destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3]. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - destruct (Mem.storev _ _ _); try discriminate. - inv H. - trivial. -Qed. - -Lemma exec_store_reg_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_reg t rs m rd ra ro = Next rs' m' -> - exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Lemma exec_store_regxs_pc_var: - forall t rs m rd ra ro rs' m' v, - exec_store_regxs t rs m rd ra ro = Next rs' m' -> - exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'. -Proof. - intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate. - destruct (Mem.storev _ _ _). - - inv H. apply next_eq; auto. - - discriminate. -Qed. - -Theorem exec_basic_instr_pc_var: - forall ge i rs m rs' m' v, - exec_basic_instr ge i rs m = Next rs' m' -> - exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i. - - unfold exec_arith_instr in *. destruct i; destruct i. - all: try (exploreInst; inv H; apply next_eq; auto; - apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). -(* - (* Some cases treated seperately because exploreInst destructs too much *) - all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *) - - destruct i. - + exploreInst; apply exec_load_offset_pc_var; auto. - + exploreInst; apply exec_load_reg_pc_var; auto. - + exploreInst; apply exec_load_regxs_pc_var; auto. - + apply exec_load_offset_q_pc_var; auto. - + apply exec_load_offset_o_pc_var; auto. - - destruct i. - + exploreInst; apply exec_store_offset_pc_var; auto. - + exploreInst; apply exec_store_reg_pc_var; auto. - + exploreInst; apply exec_store_regxs_pc_var; auto. - + apply exec_store_q_offset_pc_var; auto. - + apply exec_store_o_offset_pc_var; auto. - - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.storev _ _ _ _); try discriminate. - inv H. apply next_eq; auto. apply functional_extensionality. intros. - rewrite (regset_double_set GPR32 PC); try discriminate. - rewrite (regset_double_set GPR12 PC); try discriminate. - rewrite (regset_double_set FP PC); try discriminate. reflexivity. - - repeat (rewrite Pregmap.gso; try discriminate). - destruct (Mem.loadv _ _ _); try discriminate. - destruct (rs GPR12); try discriminate. - destruct (Mem.free _ _ _ _); try discriminate. - inv H. apply next_eq; auto. - rewrite (regset_double_set GPR32 PC). - rewrite (regset_double_set GPR12 PC). reflexivity. - all: discriminate. - - destruct rs0; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - destruct rd; try discriminate. inv H. apply next_eq; auto. - repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate. - - inv H. apply next_eq; auto. -Qed. - - diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml deleted file mode 100644 index 785887b2..00000000 --- a/mppa_k1c/Asmexpand.ml +++ /dev/null @@ -1,636 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(* Expanding built-ins and some pseudo-instructions by rewriting - of the RISC-V assembly code. *) - -open Asm -open Asmexpandaux -open AST -open Camlcoq - -exception Error of string - -(* Useful constants and helper functions *) - -let _0 = Integers.Int.zero -let _1 = Integers.Int.one -let _2 = coqint_of_camlint 2l -let _4 = coqint_of_camlint 4l -let _8 = coqint_of_camlint 8l -let _16 = coqint_of_camlint 16l -let _m1 = coqint_of_camlint (-1l) - -let wordsize = if Archi.ptr64 then 8 else 4 - -let align n a = (n + a - 1) land (-a) - -let stack_pointer = Asmvliw.GPR12 - -(* Emit instruction sequences that set or offset a register by a constant. *) -(* - let expand_loadimm32 dst n = - List.iter emit (Asmgen.loadimm32 dst n []) -*) -let expand_addptrofs dst src n = - List.iter emit (basic_to_instruction (Asmvliw.PArith (Asmblockgen.addptrofs dst src n)) :: []) -let expand_storeind_ptr src base ofs = - List.iter emit (basic_to_instruction (Asmblockgen.storeind_ptr src base ofs) :: []) -let expand_loadind_ptr dst base ofs = - List.iter emit (basic_to_instruction (Asmblockgen.loadind_ptr base ofs dst) :: []) - -(* Built-ins. They come in two flavors: - - annotation statements: take their arguments in registers or stack - locations; generate no code; - - inlined by the compiler: take their arguments in arbitrary - registers. -*) - -(* Fix-up code around calls to variadic functions. Floating-point arguments - residing in FP registers need to be moved to integer registers. *) - -let int_param_regs = let open Asmvliw in [| GPR0; GPR1; GPR2; GPR3; GPR4; GPR5; GPR6; GPR7; GPR8; GPR9; GPR10; GPR11 |] -(* let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |] *) -let float_param_regs = [| |] - -let fixup_variadic_call pos tyl = assert false -(*if pos < 8 then - match tyl with - | [] -> - () - | (Tint | Tany32) :: tyl -> - fixup_variadic_call (pos + 1) tyl - | Tsingle :: tyl -> - let rs =float_param_regs.(pos) - and rd = int_param_regs.(pos) in - emit (Pfmvxs(rd, rs)); - fixup_variadic_call (pos + 1) tyl - | Tlong :: tyl -> - let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in - fixup_variadic_call pos' tyl - | (Tfloat | Tany64) :: tyl -> - if Archi.ptr64 then begin - let rs = float_param_regs.(pos) - and rd = int_param_regs.(pos) in - emit (Pfmvxd(rd, rs)); - fixup_variadic_call (pos + 1) tyl - end else begin - let pos = align pos 2 in - if pos < 8 then begin - let rs = float_param_regs.(pos) - and rd1 = int_param_regs.(pos) - and rd2 = int_param_regs.(pos + 1) in - emit (Paddiw(X2, X X2, Integers.Int.neg _16)); - emit (Pfsd(rs, X2, Ofsimm _0)); - emit (Plw(rd1, X2, Ofsimm _0)); - emit (Plw(rd2, X2, Ofsimm _4)); - emit (Paddiw(X2, X X2, _16)); - fixup_variadic_call (pos + 2) tyl - end - end -*) - -let fixup_call sg = - if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args - -(* Handling of annotations *) - -let expand_annot_val kind txt targ args res = - emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none)); - match args, res with - | [BA(Asmvliw.IR src)], BR(Asmvliw.IR dst) -> - if dst <> src then emit (Pmv (dst, src)) - | _, _ -> - raise (Error "ill-formed __builtin_annot_val") - -(* Handling of memcpy *) - -let emit_move dst r = - if dst <> r - then emit (Paddil(dst, r, Z.zero));; - -(* FIXME DMonniaux this is probably not complete *) -let get_builtin_arg dst arg = - match arg with - | BA (Asmvliw.IR reg) -> emit_move dst reg - | BA (ireg) -> failwith "get_builtin_arg: BA_int(not ireg)" - | BA_int _ -> failwith "get_builtin_arg: BA_int" - | BA_long _ -> failwith "get_builtin_arg: BA_long" - | BA_float _ -> failwith "get_builtin_arg: BA_float" - | BA_single _ -> failwith "get_builtin_arg: BA_single" - | BA_loadstack _ -> failwith "get_builtin_arg: BA_loadstack" - | BA_addrstack ofs -> emit (Paddil(dst, stack_pointer, ofs)) - | BA_loadglobal _ -> failwith "get_builtin_arg: BA_loadglobal" - | BA_addrglobal _ -> failwith "get_builtin_arg: BA_addrglobal" - | BA_splitlong _ -> failwith "get_builtin_arg: BA_splitlong" - | BA_addptr _ -> failwith "get_builtin_arg: BA_addptr";; - -let smart_memcpy = true - -(* FIXME DMonniaux this is really suboptimal (byte per byte) *) -let expand_builtin_memcpy_big sz al src dst = - assert (sz > Z.zero); - let dstptr = Asmvliw.GPR62 - and srcptr = Asmvliw.GPR63 - and tmpbuf = Asmvliw.GPR61 - and tmpbuf2 = Asmvliw.R60R61 - and caml_sz = camlint64_of_coqint sz in - get_builtin_arg dstptr dst; - get_builtin_arg srcptr src; - let caml_sz_div16 = Int64.shift_right caml_sz 4 - and sixteen = coqint_of_camlint64 16L in - if smart_memcpy - then - let remaining = ref caml_sz - and offset = ref 0L in - let cpy buf size load store = - (if !remaining >= size - then - let zofs = coqint_of_camlint64 !offset in - begin - emit Psemi; - emit (load buf srcptr (AOff zofs)); - emit Psemi; - emit (store buf dstptr (AOff zofs)); - remaining := Int64.sub !remaining size; - offset := Int64.add !offset size - end) in - begin - (if caml_sz_div16 >= 2L - then - begin - emit (Pmake (tmpbuf, (coqint_of_camlint64 caml_sz_div16))); - emit Psemi; - let lbl = new_label() in - emit (Ploopdo (tmpbuf, lbl)); - emit Psemi; - emit (Plq (tmpbuf2, srcptr, AOff Z.zero)); - emit (Paddil (srcptr, srcptr, sixteen)); - emit Psemi; - emit (Psq (tmpbuf2, dstptr, AOff Z.zero)); - emit (Paddil (dstptr, dstptr, sixteen)); - emit Psemi; - emit (Plabel lbl); - remaining := Int64.sub !remaining (Int64.shift_left caml_sz_div16 4) - end); - - cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z)); - cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z)); - cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z)); - cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z)); - cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z)); - assert (!remaining = 0L) - end - else - begin - emit (Pmake (tmpbuf, sz)); - emit Psemi; - let lbl = new_label() in - emit (Ploopdo (tmpbuf, lbl)); - emit Psemi; - emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero)); - emit (Paddil (srcptr, srcptr, Z.one)); - emit Psemi; - emit (Psb (tmpbuf, dstptr, AOff Z.zero)); - emit (Paddil (dstptr, dstptr, Z.one)); - emit Psemi; - emit (Plabel lbl); - end;; - -let expand_builtin_memcpy sz al args = - match args with - | [dst; src] -> - expand_builtin_memcpy_big sz al src dst - | _ -> assert false;; - -(* Handling of volatile reads and writes *) -(* FIXME probably need to check for size of displacement *) -let expand_builtin_vload_common chunk base ofs res = - match chunk, res with - | Mint8unsigned, BR(Asmvliw.IR res) -> - emit (Plbu (TRAP, res, base, AOff ofs)) - | Mint8signed, BR(Asmvliw.IR res) -> - emit (Plb (TRAP, res, base, AOff ofs)) - | Mint16unsigned, BR(Asmvliw.IR res) -> - emit (Plhu (TRAP, res, base, AOff ofs)) - | Mint16signed, BR(Asmvliw.IR res) -> - emit (Plh (TRAP, res, base, AOff ofs)) - | Mint32, BR(Asmvliw.IR res) -> - emit (Plw (TRAP, res, base, AOff ofs)) - | Mint64, BR(Asmvliw.IR res) -> - emit (Pld (TRAP, res, base, AOff ofs)) - | Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) -> - let ofs' = Integers.Ptrofs.add ofs _4 in - if base <> res2 then begin - emit (Plw (TRAP, res2, base, AOff ofs)); - emit (Plw (TRAP, res1, base, AOff ofs')) - end else begin - emit (Plw (TRAP, res1, base, AOff ofs')); - emit (Plw (TRAP, res2, base, AOff ofs)) - end - | Mfloat32, BR(Asmvliw.IR res) -> - emit (Pfls (TRAP, res, base, AOff ofs)) - | Mfloat64, BR(Asmvliw.IR res) -> - emit (Pfld (TRAP, res, base, AOff ofs)) - | _ -> - assert false - -let expand_builtin_vload chunk args res = - match args with - | [BA(Asmvliw.IR addr)] -> - expand_builtin_vload_common chunk addr _0 res - | [BA_addrstack ofs] -> - expand_builtin_vload_common chunk stack_pointer ofs res - | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs))] -> - expand_builtin_vload_common chunk addr ofs res - | _ -> - assert false - - -let expand_builtin_vstore_common chunk base ofs src = - match chunk, src with - | (Mint8signed | Mint8unsigned), BA(Asmvliw.IR src) -> - emit (Psb (src, base, AOff ofs)) - | (Mint16signed | Mint16unsigned), BA(Asmvliw.IR src) -> - emit (Psh (src, base, AOff ofs)) - | Mint32, BA(Asmvliw.IR src) -> - emit (Psw (src, base, AOff ofs)) - | Mint64, BA(Asmvliw.IR src) -> - emit (Psd (src, base, AOff ofs)) - | Mint64, BA_splitlong(BA(Asmvliw.IR src1), BA(Asmvliw.IR src2)) -> - let ofs' = Integers.Ptrofs.add ofs _4 in - emit (Psw (src2, base, AOff ofs)); - emit (Psw (src1, base, AOff ofs')) - | Mfloat32, BA(Asmvliw.IR src) -> - emit (Pfss (src, base, AOff ofs)) - | Mfloat64, BA(Asmvliw.IR src) -> - emit (Pfsd (src, base, AOff ofs)) - | _ -> - assert false - -let expand_builtin_vstore chunk args = - match args with - | [BA(Asmvliw.IR addr); src] -> - expand_builtin_vstore_common chunk addr _0 src - | [BA_addrstack ofs; src] -> - expand_builtin_vstore_common chunk stack_pointer ofs src - | [BA_addptr(BA(Asmvliw.IR addr), (BA_int ofs | BA_long ofs)); src] -> - expand_builtin_vstore_common chunk addr ofs src - | _ -> - assert false - -(* Handling of varargs *) - -(* Size in words of the arguments to a function. This includes both - arguments passed in registers and arguments passed on stack. *) - -let rec args_size sz = function - | [] -> sz - | (Tint | Tsingle | Tany32) :: l -> - args_size (sz + 1) l - | (Tlong | Tfloat | Tany64) :: l -> - args_size (if Archi.ptr64 then sz + 1 else align sz 2 + 2) l - -let arguments_size sg = - args_size 0 sg.sig_args - -let _nbregargs_ = 12 -let _alignment_ = 8 - -let save_arguments first_reg base_ofs = let open Asmvliw in - for i = first_reg to (_nbregargs_ - 1) do begin - expand_storeind_ptr - int_param_regs.(i) - GPR12 - (Integers.Ptrofs.repr (Z.add base_ofs (Z.of_uint ((i - first_reg) * wordsize)))); - emit Psemi - end done - -let vararg_start_ofs : Z.t option ref = ref None - -let expand_builtin_va_start r = (* assert false *) -match !vararg_start_ofs with - | None -> - invalid_arg "Fatal error: va_start used in non-vararg function" - | Some ofs -> - expand_addptrofs Asmvliw.GPR32 stack_pointer (Integers.Ptrofs.repr ofs); - emit Psemi; - expand_storeind_ptr Asmvliw.GPR32 r Integers.Ptrofs.zero - -(* Auxiliary for 64-bit integer arithmetic built-ins. They expand to - two instructions, one computing the low 32 bits of the result, - followed by another computing the high 32 bits. In cases where - the first instruction would overwrite arguments to the second - instruction, we must go through X31 to hold the low 32 bits of the result. -*) - -let expand_int64_arith conflict rl fn = assert false -(*if conflict then (fn X31; emit (Pmv(rl, X31))) else fn rl *) - -(* Byte swaps. There are no specific instructions, so we use standard, - not-very-efficient formulas. *) - -let expand_bswap16 d s = let open Asmvliw in - (* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *) - emit (Pandiw(GPR32, s, coqint_of_camlint 0xFFl)); emit Psemi; - emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; - emit (Psrliw(d, s, _8)); emit Psemi; - emit (Pandiw(d, d, coqint_of_camlint 0xFFl)); - emit (Porw(d, GPR32, d)); emit Psemi - -let expand_bswap32 d s = let open Asmvliw in - (* d = (s << 24) - | (((s >> 8) & 0xFF) << 16) - | (((s >> 16) & 0xFF) << 8) - | (s >> 24) *) - emit (Pslliw(GPR16, s, coqint_of_camlint 24l)); emit Psemi; - emit (Psrliw(GPR32, s, _8)); emit Psemi; - emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; - emit (Pslliw(GPR32, GPR32, _16)); emit Psemi; - emit (Porw(GPR16, GPR16, GPR31)); emit Psemi; - emit (Psrliw(GPR32, s, _16)); emit Psemi; - emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; - emit (Pslliw(GPR32, GPR32, _8)); emit Psemi; - emit (Porw(GPR16, GPR16, GPR32)); emit Psemi; - emit (Psrliw(GPR32, s, coqint_of_camlint 24l)); emit Psemi; - emit (Porw(d, GPR16, GPR32)); emit Psemi - -let expand_bswap64 d s = let open Asmvliw in - (* d = s << 56 - | (((s >> 8) & 0xFF) << 48) - | (((s >> 16) & 0xFF) << 40) - | (((s >> 24) & 0xFF) << 32) - | (((s >> 32) & 0xFF) << 24) - | (((s >> 40) & 0xFF) << 16) - | (((s >> 48) & 0xFF) << 8) - | s >> 56 *) - emit (Psllil(GPR16, s, coqint_of_camlint 56l)); emit Psemi; - List.iter - (fun (n1, n2) -> - emit (Psrlil(GPR32, s, coqint_of_camlint n1)); emit Psemi; - emit (Pandil(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi; - emit (Psllil(GPR32, GPR32, coqint_of_camlint n2)); emit Psemi; - emit (Porl(GPR16, GPR16, GPR32)); emit Psemi;) - [(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)]; - emit (Psrlil(GPR32, s, coqint_of_camlint 56l)); emit Psemi; - emit (Porl(d, GPR16, GPR32)); emit Psemi - -(* Handling of compiler-inlined builtins *) -let last_system_register = 511l -let not_system_register cn =cn<0l || cn>last_system_register - -let expand_builtin_inline name args res = let open Asmvliw in - match name, args, res with - (* Synchronization *) - | "__builtin_membar", [], _ -> - () - (* Vararg stuff *) - | "__builtin_va_start", [BA(IR a)], _ -> - expand_builtin_va_start a - | "__builtin_clzll", [BA(IR a)], BR(IR res) -> - emit (Pclzll(res, a)) - | "__builtin_k1_stsud", [BA(IR a1); BA(IR a2)], BR(IR res) -> - emit (Pstsud(res, a1, a2)) - | "__builtin_k1_get", [BA_int(n)], BR(IR res) -> - let cn = camlint_of_coqint n in - (if not_system_register cn - then failwith (Printf.sprintf "__builtin_k1_get(n): n must be between 0 and %ld, was %ld" last_system_register cn) - else emit (Pgetn(n, res))) - | "__builtin_k1_set", [BA_int(n); BA(IR src)], _ -> - let cn = camlint_of_coqint n in - (if not_system_register cn - then failwith (Printf.sprintf "__builtin_k1_set(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) - else emit (Psetn(n, src))) - | "__builtin_k1_wfxl", [BA_int(n); BA(IR src)], _ -> - let cn = camlint_of_coqint n in - (if not_system_register cn - then failwith (Printf.sprintf "__builtin_k1_wfxl(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) - else emit (Pwfxl(n, src))) - | "__builtin_k1_wfxm", [BA_int(n); BA(IR src)], _ -> - let cn = camlint_of_coqint n in - (if not_system_register cn - then failwith (Printf.sprintf "__builtin_k1_wfxm(n, val): n must be between 0 and %ld, was %ld" last_system_register cn) - else emit (Pwfxm(n, src))) - | "__builtin_k1_ldu", [BA(IR addr)], BR(IR res) -> - emit (Pldu(res, addr)) - | "__builtin_k1_lbzu", [BA(IR addr)], BR(IR res) -> - emit (Plbzu(res, addr)) - | "__builtin_k1_lhzu", [BA(IR addr)], BR(IR res) -> - emit (Plhzu(res, addr)) - | "__builtin_k1_lwzu", [BA(IR addr)], BR(IR res) -> - emit (Plwzu(res, addr)) - | "__builtin_k1_alclrd", [BA(IR addr)], BR(IR res) -> - emit (Palclrd(res, addr)) - | "__builtin_k1_alclrw", [BA(IR addr)], BR(IR res) -> - emit (Palclrw(res, addr)) - | "__builtin_k1_await", [], _ -> - emit Pawait - | "__builtin_k1_sleep", [], _ -> - emit Psleep - | "__builtin_k1_stop", [], _ -> - emit Pstop - | "__builtin_k1_barrier", [], _ -> - emit Pbarrier - | "__builtin_k1_fence", [], _ -> - emit Pfence - | "__builtin_k1_dinval", [], _ -> - emit Pdinval - | "__builtin_k1_dinvall", [BA(IR addr)], _ -> - emit (Pdinvall addr) - | "__builtin_k1_dtouchl", [BA(IR addr)], _ -> - emit (Pdtouchl addr) - | "__builtin_k1_iinval", [], _ -> - emit Piinval - | "__builtin_k1_iinvals", [BA(IR addr)], _ -> - emit (Piinvals addr) - | "__builtin_k1_itouchl", [BA(IR addr)], _ -> - emit (Pitouchl addr) - | "__builtin_k1_dzerol", [BA(IR addr)], _ -> - emit (Pdzerol addr) -(*| "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> - (if res <> incr_res - then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); - emit (Pafaddd(addr, res)) - | "__builtin_k1_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) -> - (if res <> incr_res - then (emit (Asm.Pmv(res, incr_res)); emit Psemi)); - emit (Pafaddw(addr, res)) *) (* see #157 *) - | "__builtin_alclrd", [BA(IR addr)], BR(IR res) -> - emit (Palclrd(res, addr)) - | "__builtin_alclrw", [BA(IR addr)], BR(IR res) -> - emit (Palclrw(res, addr)) - | "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> - expand_bswap16 res a1 - | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) -> - expand_bswap32 res a1 - | "__builtin_bswap64", [BA(IR src)], BR(IR res) -> - expand_bswap64 res src - - (* Byte swaps *) -(*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) -> - expand_bswap16 res a1 - | "__builtin_fabs", [BA(FR a1)], BR(FR res) -> - emit (Pfabsd(res, a1)) -*) - (* Catch-all *) - | _ -> - raise (Error ("unrecognized builtin " ^ name)) - -(* Expansion of instructions *) - -let expand_instruction instr = - match instr with - | Pallocframe (sz, ofs) -> - let sg = get_current_function_sig() in - emit (Pmv (Asmvliw.GPR17, stack_pointer)); - if sg.sig_cc.cc_vararg then begin - let n = arguments_size sg in - let extra_sz = if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) in - let full_sz = Z.add sz (Z.of_uint extra_sz) in - expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.neg full_sz)); - emit Psemi; - expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs; - emit Psemi; - let va_ofs = - let extra_ofs = if n <= _nbregargs_ then 0 else ((n - _nbregargs_) * wordsize) in - Z.add sz (Z.of_sint extra_ofs) in - vararg_start_ofs := Some va_ofs; - save_arguments n va_ofs - end else begin - let below = Integers.Ptrofs.repr (Z.neg sz) in - expand_addptrofs stack_pointer stack_pointer below; - emit Psemi; (* Psemi required to fit in resource constraints *) - expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below); - vararg_start_ofs := None - end - | Pfreeframe (sz, ofs) -> - let sg = get_current_function_sig() in - let extra_sz = - if sg.sig_cc.cc_vararg then begin - let n = arguments_size sg in - if n >= _nbregargs_ then 0 else (* align _alignment_ *) ((_nbregargs_ - n) * wordsize) - end else 0 in - expand_addptrofs stack_pointer stack_pointer (Integers.Ptrofs.repr (Z.add sz (Z.of_uint extra_sz))) - -(*| Pseqw(rd, rs1, rs2) -> - (* emulate based on the fact that x == 0 iff x - (* emulate based on the fact that x != 0 iff 0 - (* emulate based on the fact that x == 0 iff x - (* emulate based on the fact that x != 0 iff 0 - assert Archi.ptr64; - emit (Paddiw (rd, rs, Integers.Int.zero)) (* 32-bit sign extension *) - -(*| Pjal_r(r, sg) -> - fixup_call sg; emit instr - | Pjal_s(symb, sg) -> - fixup_call sg; emit instr - | Pj_r(r, sg) when r <> X1 -> - fixup_call sg; emit instr - | Pj_s(symb, sg) -> - fixup_call sg; emit instr - -*)| Pbuiltin (ef,args,res) -> - begin match ef with - | EF_builtin (name,sg) -> - expand_builtin_inline (camlstring_of_coqstring name) args res - | EF_vload chunk -> - expand_builtin_vload chunk args res - | EF_vstore chunk -> - expand_builtin_vstore chunk args -(* | EF_annot_val (kind,txt,targ) -> - expand_annot_val kind txt targ args res *) - | EF_memcpy(sz, al) -> - expand_builtin_memcpy sz al args - (* | EF_annot _ | EF_debug _ | EF_inline_asm _ -> - emit instr - *) - | EF_malloc -> failwith "asmexpand: malloc" - | EF_free -> failwith "asmexpand: free" - | EF_debug _ -> failwith "asmexpand: debug" - | EF_annot _ -> emit instr - | EF_annot_val (kind, txt, targ) -> expand_annot_val kind txt targ args res - | EF_external _ -> failwith "asmexpand: external" - | EF_inline_asm _ -> emit instr - | EF_runtime _ -> failwith "asmexpand: runtime" - | EF_profiling _ -> emit instr - end - | _ -> - emit instr - -(* NOTE: Dwarf register maps for RV32G are not yet specified - officially. This is just a placeholder. *) -let int_reg_to_dwarf = let open Asmvliw in function - | GPR0 -> 1 | GPR1 -> 2 | GPR2 -> 3 | GPR3 -> 4 | GPR4 -> 5 - | GPR5 -> 6 | GPR6 -> 7 | GPR7 -> 8 | GPR8 -> 9 | GPR9 -> 10 - | GPR10 -> 11 | GPR11 -> 12 | GPR12 -> 13 | GPR13 -> 14 | GPR14 -> 15 - | GPR15 -> 16 | GPR16 -> 17 | GPR17 -> 18 | GPR18 -> 19 | GPR19 -> 20 - | GPR20 -> 21 | GPR21 -> 22 | GPR22 -> 23 | GPR23 -> 24 | GPR24 -> 25 - | GPR25 -> 26 | GPR26 -> 27 | GPR27 -> 28 | GPR28 -> 29 | GPR29 -> 30 - | GPR30 -> 31 | GPR31 -> 32 | GPR32 -> 33 | GPR33 -> 34 | GPR34 -> 35 - | GPR35 -> 36 | GPR36 -> 37 | GPR37 -> 38 | GPR38 -> 39 | GPR39 -> 40 - | GPR40 -> 41 | GPR41 -> 42 | GPR42 -> 43 | GPR43 -> 44 | GPR44 -> 45 - | GPR45 -> 46 | GPR46 -> 47 | GPR47 -> 48 | GPR48 -> 49 | GPR49 -> 50 - | GPR50 -> 51 | GPR51 -> 52 | GPR52 -> 53 | GPR53 -> 54 | GPR54 -> 55 - | GPR55 -> 56 | GPR56 -> 57 | GPR57 -> 58 | GPR58 -> 59 | GPR59 -> 60 - | GPR60 -> 61 | GPR61 -> 62 | GPR62 -> 63 | GPR63 -> 64 - -let preg_to_dwarf = let open Asmvliw in function - | IR r -> int_reg_to_dwarf r - | RA -> 65 (* FIXME - No idea what is $ra DWARF number in k1-gdb *) - | _ -> assert false - -let expand_function id fn = - try - set_current_function fn; - expand id (* sp= *) 2 preg_to_dwarf expand_instruction fn.fn_code; - Errors.OK (get_current_function ()) - with Error s -> - Errors.Error (Errors.msg (coqstring_of_camlstring s)) - -let expand_fundef id = function - | Internal f -> - begin match expand_function id f with - | Errors.OK tf -> Errors.OK (Internal tf) - | Errors.Error msg -> Errors.Error msg - end - | External ef -> - Errors.OK (External ef) - -let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v deleted file mode 100644 index 61856acf..00000000 --- a/mppa_k1c/Asmgen.v +++ /dev/null @@ -1,41 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Integers. -Require Import Mach Asm Asmblock Asmblockgen Machblockgen. -Require Import PostpassScheduling. -Require Import Errors String. -Require Compopts. - -Local Open Scope error_monad_scope. - -Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f. - -Definition transf_program (p: Mach.program) : res Asm.program := - let mbp := (time "Machblock generation" Machblockgen.transf_program) p in - do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp; - do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp; - OK ((time "Asm generation" Asm.transf_program) abp'). - -Definition transf_function (f: Mach.function) : res Asm.function := - let mbf := Machblockgen.transf_function f in - do abf <- Asmblockgen.transf_function mbf; - OK (Asm.transf_function abf). - -Definition transl_code (f: Mach.function) (l: Mach.code) : res (list Asm.instruction) := - let mbf := Machblockgen.transf_function f in - let mbc := Machblockgen.trans_code l in - do abc <- transl_blocks mbf mbc true; - OK (unfold abc). diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v deleted file mode 100644 index f43acd37..00000000 --- a/mppa_k1c/Asmgenproof.v +++ /dev/null @@ -1,95 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Correctness proof for Asmgen *) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Mach Conventions Asm Asmgen Machblockgen Asmblockgen. -Require Import Machblockgenproof Asmblockgenproof PostpassSchedulingproof. - -Local Open Scope linking_scope. - -Definition block_passes := - mkpass Machblockgenproof.match_prog - ::: mkpass Asmblockgenproof.match_prog - ::: mkpass PostpassSchedulingproof.match_prog - ::: mkpass Asm.match_prog - ::: pass_nil _. - -Definition match_prog := pass_match (compose_passes block_passes). - -Lemma transf_program_match: - forall p tp, Asmgen.transf_program p = OK tp -> match_prog p tp. -Proof. - intros p tp H. - unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H. - inversion_clear H. apply bind_inversion in H1. destruct H1. - inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp. - unfold match_prog; simpl. - exists mbp; split. apply Machblockgenproof.transf_program_match; auto. - exists x; split. apply Asmblockgenproof.transf_program_match; auto. - exists x0; split. apply PostpassSchedulingproof.transf_program_match; auto. - exists tp; split. apply Asm.transf_program_match; auto. auto. -Qed. - -(** Return Address Offset *) - -Definition return_address_offset: Mach.function -> Mach.code -> ptrofs -> Prop := - Mach_return_address_offset Asmblockgenproof.return_address_offset. - -Lemma return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros; unfold return_address_offset; eapply Mach_return_address_exists; eauto. - intros; eapply Asmblockgenproof.return_address_exists; eauto. -Qed. - - -Section PRESERVATION. - -Variable prog: Mach.program. -Variable tprog: program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Theorem transf_program_correct: - forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). -Proof. - unfold match_prog in TRANSF. simpl in TRANSF. - inv TRANSF. inv H. inv H1. inv H. inv H2. inv H. inv H3. inv H. - eapply compose_forward_simulations. - exploit Machblockgenproof.transf_program_correct; eauto. - unfold Machblockgenproof.inv_trans_rao. - eapply compose_forward_simulations. apply Asmblockgenproof.transf_program_correct; eauto. - eapply compose_forward_simulations. apply PostpassSchedulingproof.transf_program_correct; eauto. - apply Asm.transf_program_correct. eauto. -Qed. - -End PRESERVATION. - -Instance TransfAsm: TransfLink match_prog := pass_match_link (compose_passes block_passes). - -(*******************************************) -(* Stub actually needed by driver/Compiler *) - -Module Asmgenproof0. - -Definition return_address_offset := return_address_offset. - -End Asmgenproof0. diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v deleted file mode 100644 index b085fb1d..00000000 --- a/mppa_k1c/Asmvliw.v +++ /dev/null @@ -1,1812 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Abstract syntax and semantics for VLIW semantics of K1c assembly language. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Stacklayout. -Require Import Conventions. -Require Import Errors. -Require Import Sorting.Permutation. -Require Import Chunks. - -(** * Abstract syntax *) - -(** A K1c program is syntactically given as a list of functions. - Each function is associated to a list of bundles of type [bblock] below. - Hence, syntactically, we view each bundle as a basic block: - this view induces our sequential semantics of bundles defined in [Asmblock]. -*) - -(** General Purpose registers. *) - -Inductive gpreg: Type := - | GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg - | GPR5: gpreg | GPR6: gpreg | GPR7: gpreg | GPR8: gpreg | GPR9: gpreg - | GPR10: gpreg | GPR11: gpreg | GPR12: gpreg | GPR13: gpreg | GPR14: gpreg - | GPR15: gpreg | GPR16: gpreg | GPR17: gpreg | GPR18: gpreg | GPR19: gpreg - | GPR20: gpreg | GPR21: gpreg | GPR22: gpreg | GPR23: gpreg | GPR24: gpreg - | GPR25: gpreg | GPR26: gpreg | GPR27: gpreg | GPR28: gpreg | GPR29: gpreg - | GPR30: gpreg | GPR31: gpreg | GPR32: gpreg | GPR33: gpreg | GPR34: gpreg - | GPR35: gpreg | GPR36: gpreg | GPR37: gpreg | GPR38: gpreg | GPR39: gpreg - | GPR40: gpreg | GPR41: gpreg | GPR42: gpreg | GPR43: gpreg | GPR44: gpreg - | GPR45: gpreg | GPR46: gpreg | GPR47: gpreg | GPR48: gpreg | GPR49: gpreg - | GPR50: gpreg | GPR51: gpreg | GPR52: gpreg | GPR53: gpreg | GPR54: gpreg - | GPR55: gpreg | GPR56: gpreg | GPR57: gpreg | GPR58: gpreg | GPR59: gpreg - | GPR60: gpreg | GPR61: gpreg | GPR62: gpreg | GPR63: gpreg. - -Definition ireg := gpreg. -Definition freg := gpreg. - -Lemma gpreg_eq: forall (x y: gpreg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Inductive gpreg_q : Type := -| R0R1 | R2R3 | R4R5 | R6R7 | R8R9 -| R10R11 | R12R13 | R14R15 | R16R17 | R18R19 -| R20R21 | R22R23 | R24R25 | R26R27 | R28R29 -| R30R31 | R32R33 | R34R35 | R36R37 | R38R39 -| R40R41 | R42R43 | R44R45 | R46R47 | R48R49 -| R50R51 | R52R53 | R54R55 | R56R57 | R58R59 -| R60R61 | R62R63. - -Lemma gpreg_q_eq : forall (x y : gpreg_q), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Definition gpreg_q_expand (x : gpreg_q) : gpreg * gpreg := - match x with - | R0R1 => (GPR0, GPR1) - | R2R3 => (GPR2, GPR3) - | R4R5 => (GPR4, GPR5) - | R6R7 => (GPR6, GPR7) - | R8R9 => (GPR8, GPR9) - | R10R11 => (GPR10, GPR11) - | R12R13 => (GPR12, GPR13) - | R14R15 => (GPR14, GPR15) - | R16R17 => (GPR16, GPR17) - | R18R19 => (GPR18, GPR19) - | R20R21 => (GPR20, GPR21) - | R22R23 => (GPR22, GPR23) - | R24R25 => (GPR24, GPR25) - | R26R27 => (GPR26, GPR27) - | R28R29 => (GPR28, GPR29) - | R30R31 => (GPR30, GPR31) - | R32R33 => (GPR32, GPR33) - | R34R35 => (GPR34, GPR35) - | R36R37 => (GPR36, GPR37) - | R38R39 => (GPR38, GPR39) - | R40R41 => (GPR40, GPR41) - | R42R43 => (GPR42, GPR43) - | R44R45 => (GPR44, GPR45) - | R46R47 => (GPR46, GPR47) - | R48R49 => (GPR48, GPR49) - | R50R51 => (GPR50, GPR51) - | R52R53 => (GPR52, GPR53) - | R54R55 => (GPR54, GPR55) - | R56R57 => (GPR56, GPR57) - | R58R59 => (GPR58, GPR59) - | R60R61 => (GPR60, GPR61) - | R62R63 => (GPR62, GPR63) - end. - -Inductive gpreg_o : Type := -| R0R1R2R3 | R4R5R6R7 | R8R9R10R11 | R12R13R14R15 -| R16R17R18R19 | R20R21R22R23 | R24R25R26R27 | R28R29R30R31 -| R32R33R34R35 | R36R37R38R39 | R40R41R42R43 | R44R45R46R47 -| R48R49R50R51 | R52R53R54R55 | R56R57R58R59 | R60R61R62R63. - -Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg := - match x with - | R0R1R2R3 => (GPR0, GPR1, GPR2, GPR3) - | R4R5R6R7 => (GPR4, GPR5, GPR6, GPR7) - | R8R9R10R11 => (GPR8, GPR9, GPR10, GPR11) - | R12R13R14R15 => (GPR12, GPR13, GPR14, GPR15) - | R16R17R18R19 => (GPR16, GPR17, GPR18, GPR19) - | R20R21R22R23 => (GPR20, GPR21, GPR22, GPR23) - | R24R25R26R27 => (GPR24, GPR25, GPR26, GPR27) - | R28R29R30R31 => (GPR28, GPR29, GPR30, GPR31) - | R32R33R34R35 => (GPR32, GPR33, GPR34, GPR35) - | R36R37R38R39 => (GPR36, GPR37, GPR38, GPR39) - | R40R41R42R43 => (GPR40, GPR41, GPR42, GPR43) - | R44R45R46R47 => (GPR44, GPR45, GPR46, GPR47) - | R48R49R50R51 => (GPR48, GPR49, GPR50, GPR51) - | R52R53R54R55 => (GPR52, GPR53, GPR54, GPR55) - | R56R57R58R59 => (GPR56, GPR57, GPR58, GPR59) - | R60R61R62R63 => (GPR60, GPR61, GPR62, GPR63) - end. - -Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Inductive preg: Type := - | IR: gpreg -> preg (**r integer general purpose registers *) - | RA: preg - | PC: preg - . - -Coercion IR: gpreg >-> preg. - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -(** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *) - -Notation "'SP'" := GPR12 (only parsing) : asm. -Notation "'FP'" := GPR17 (only parsing) : asm. -Notation "'MFP'" := R17 (only parsing) : asm. -Notation "'GPRA'" := GPR16 (only parsing) : asm. -Notation "'RTMP'" := GPR32 (only parsing) : asm. - -Inductive btest: Type := - | BTdnez (**r Double Not Equal to Zero *) - | BTdeqz (**r Double Equal to Zero *) - | BTdltz (**r Double Less Than Zero *) - | BTdgez (**r Double Greater Than or Equal to Zero *) - | BTdlez (**r Double Less Than or Equal to Zero *) - | BTdgtz (**r Double Greater Than Zero *) - | BTwnez (**r Word Not Equal to Zero *) - | BTweqz (**r Word Equal to Zero *) - | BTwltz (**r Word Less Than Zero *) - | BTwgez (**r Word Greater Than or Equal to Zero *) - | BTwlez (**r Word Less Than or Equal to Zero *) - | BTwgtz (**r Word Greater Than Zero *) - . - -Inductive itest: Type := - | ITne (**r Not Equal *) - | ITeq (**r Equal *) - | ITlt (**r Less Than *) - | ITge (**r Greater Than or Equal *) - | ITle (**r Less Than or Equal *) - | ITgt (**r Greater Than *) - | ITneu (**r Unsigned Not Equal *) - | ITequ (**r Unsigned Equal *) - | ITltu (**r Less Than Unsigned *) - | ITgeu (**r Greater Than or Equal Unsigned *) - | ITleu (**r Less Than or Equal Unsigned *) - | ITgtu (**r Greater Than Unsigned *) - . - -Inductive ftest: Type := - | FTone (**r Ordered and Not Equal *) - | FTueq (**r Unordered or Equal *) - | FToeq (**r Ordered and Equal *) - | FTune (**r Unordered or Not Equal *) - | FTolt (**r Ordered and Less Than *) - | FTuge (**r Unordered or Greater Than or Equal *) - | FToge (**r Ordered and Greater Than or Equal *) - | FTult (**r Unordered or Less Than *) - . - -(** Offsets for load and store instructions. An offset is either an - immediate integer or the low part of a symbol. *) - -Definition offset : Type := ptrofs. - -(** We model a subset of the K1c instruction set. In particular, we do not - support floats yet. - - Although it is possible to use the 32-bits mode, for now we don't support it. - - We follow a design close to the one used for the Risc-V port: one set of - pseudo-instructions for 32-bit integer arithmetic, with suffix W, another - set for 64-bit integer arithmetic, with suffix L. - - When mapping to actual instructions, the OCaml code in TargetPrinter.ml - throws an error if we are not in 64-bits mode. -*) - -(** * Instructions *) - -Definition label := positive. - -(** Instructions to be expanded in control-flow *) -Inductive ex_instruction : Type := - (* Pseudo-instructions *) - | Pbuiltin: external_function -> list (builtin_arg preg) - -> builtin_res preg -> ex_instruction (**r built-in function (pseudo) *) -. - -(** FIXME: comment not up to date ! - - - The pseudo-instructions are the following: - -- [Ploadsymbol]: load the address of a symbol in an integer register. - Expands to the [la] assembler pseudo-instruction, which does the right - thing even if we are in PIC mode. - -- [Pallocframe sz pos]: in the formal semantics, this - pseudo-instruction allocates a memory block with bounds [0] and - [sz], stores the value of the stack pointer at offset [pos] in this - block, and sets the stack pointer to the address of the bottom of - this block. - In the printed ASM assembly code, this allocation is: -<< - mv x30, sp - sub sp, sp, #sz - sw x30, #pos(sp) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. - -- [Pfreeframe sz pos]: in the formal semantics, this pseudo-instruction - reads the word at [pos] of the block pointed by the stack pointer, - frees this block, and sets the stack pointer to the value read. - In the printed ASM assembly code, this freeing is just an increment of [sp]: -<< - add sp, sp, #sz ->> - Again, our memory model cannot comprehend that this operation - frees (logically) the current stack frame. - -- [Pbtbl reg table]: this is a N-way branch, implemented via a jump table - as follows: -<< - la x31, table - add x31, x31, reg - jr x31 -table: .long table[0], table[1], ... ->> - Note that [reg] contains 4 times the index of the desired table entry. -*) - -(** Control Flow instructions *) -Inductive cf_instruction : Type := - | Pret (**r return *) - | Pcall (l: label) (**r function call *) - | Picall (r: ireg) (**r function call on register value *) - | Pjumptable (r: ireg) (labels: list label) (**r N-way branch through a jump table (pseudo) *) - - (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *) - | Pgoto (l: label) (**r goto *) - | Pigoto (r: ireg) (**r goto from register *) - | Pj_l (l: label) (**r jump to label *) - - (* Conditional branches *) - | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *) - | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *) -. - -(** Loads **) -Definition concrete_default_notrap_load_value (chunk : memory_chunk) := - match chunk with - | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned - | Mint32 => Vint Int.zero - | Mint64 => Vlong Int64.zero - | Many32 | Many64 => Vundef - | Mfloat32 => Vsingle Float32.zero - | Mfloat64 => Vfloat Float.zero - end. - -Inductive load_name : Type := - | Plb (**r load byte *) - | Plbu (**r load byte unsigned *) - | Plh (**r load half word *) - | Plhu (**r load half word unsigned *) - | Plw (**r load int32 *) - | Plw_a (**r load any32 *) - | Pld (**r load int64 *) - | Pld_a (**r load any64 *) - | Pfls (**r load float *) - | Pfld (**r load 64-bit float *) -. - -Inductive ld_instruction : Type := - | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset) - | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) - | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg) - | PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset) - | PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset) -. - -(** Stores **) -Inductive store_name : Type := - | Psb (**r store byte *) - | Psh (**r store half byte *) - | Psw (**r store int32 *) - | Psw_a (**r store any32 *) - | Psd (**r store int64 *) - | Psd_a (**r store any64 *) - | Pfss (**r store float *) - | Pfsd (**r store 64-bit float *) -. - -Inductive st_instruction : Type := - | PStoreRRO (i: store_name) (rs: ireg) (ra: ireg) (ofs: offset) - | PStoreRRR (i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) - | PStoreRRRXS(i: store_name) (rs: ireg) (ra: ireg) (rofs: ireg) - | PStoreQRRO (rs: gpreg_q) (ra: ireg) (ofs: offset) - | PStoreORRO (rs: gpreg_o) (ra: ireg) (ofs: offset) -. - -(** Arithmetic instructions **) -Inductive arith_name_r : Type := - | Ploadsymbol (id: ident) (ofs: ptrofs) (**r load the address of a symbol *) -. - -Inductive arith_name_rr : Type := - | Pmv (**r register move *) - | Pnegw (**r negate word *) - | Pnegl (**r negate long *) - | Pcvtl2w (**r Convert Long to Word *) - | Psxwd (**r Sign Extend Word to Double Word *) - | Pzxwd (**r Zero Extend Word to Double Word *) - | Pextfz (stop : Z) (start : Z) (**r extract bit field, unsigned *) - | Pextfs (stop : Z) (start : Z) (**r extract bit field, signed *) - | Pextfzl (stop : Z) (start : Z) (**r extract bit field, unsigned *) - | Pextfsl (stop : Z) (start : Z) (**r extract bit field, signed *) - - | Pfabsd (**r float absolute double *) - | Pfabsw (**r float absolute word *) - | Pfnegd (**r float negate double *) - | Pfnegw (**r float negate word *) - | Pfinvw (**r float invert word *) - | Pfnarrowdw (**r float narrow 64 -> 32 bits *) - | Pfwidenlwd (**r Floating Point widen from 32 bits to 64 bits *) - | Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *) - | Pfloatuwrnsz (**r Floating Point conversion from integer (unsigned int -> SINGLE) *) - | Pfloatudrnsz (**r Floating Point Conversion from integer (unsigned long -> float) *) - | Pfloatdrnsz (**r Floating Point Conversion from integer (long -> float) *) - | Pfixedwrzz (**r Integer conversion from floating point (single -> int) *) - | Pfixeduwrzz (**r Integer conversion from floating point (single -> unsigned int) *) - | Pfixeddrzz (**r Integer conversion from floating point (float -> long) *) - | Pfixedudrzz (**r Integer conversion from floating point (float -> unsigned long) *) - | Pfixeddrzz_i32 (**r Integer conversion from floating point (float -> int) *) - | Pfixedudrzz_i32 (**r Integer conversion from floating point (float -> unsigned int) *) -. - -Inductive arith_name_ri32 : Type := - | Pmake (**r load immediate *) -. - -Inductive arith_name_ri64 : Type := - | Pmakel (**r load immediate long *) -. - -Inductive arith_name_rf32 : Type := - | Pmakefs (**r load immediate single *) -. - -Inductive arith_name_rf64 : Type := - | Pmakef (**r load immediate float *) -. - -Inductive arith_name_rrr : Type := - | Pcompw (it: itest) (**r comparison word *) - | Pcompl (it: itest) (**r comparison long *) - | Pfcompw (ft: ftest) (**r comparison float32 *) - | Pfcompl (ft: ftest) (**r comparison float64 *) - - | Paddw (**r add word *) - | Paddxw (shift : shift1_4) (**r add shift *) - | Psubw (**r sub word word *) - | Prevsubxw (shift : shift1_4) (**r sub shift word *) - | Pmulw (**r mul word *) - | Pandw (**r and word *) - | Pnandw (**r nand word *) - | Porw (**r or word *) - | Pnorw (**r nor word *) - | Pxorw (**r xor word *) - | Pnxorw (**r nxor word *) - | Pandnw (**r andn word *) - | Pornw (**r orn word *) - | Psraw (**r shift right arithmetic word *) - | Psrxw (**r shift right arithmetic word round to 0*) - | Psrlw (**r shift right logical word *) - | Psllw (**r shift left logical word *) - - | Paddl (**r add long *) - | Paddxl (shift : shift1_4) (**r add shift long *) - | Psubl (**r sub long *) - | Prevsubxl (shift : shift1_4) (**r sub shift long *) - | Pandl (**r and long *) - | Pnandl (**r nand long *) - | Porl (**r or long *) - | Pnorl (**r nor long *) - | Pxorl (**r xor long *) - | Pnxorl (**r nxor long *) - | Pandnl (**r andn long *) - | Pornl (**r orn long *) - | Pmull (**r mul long (low part) *) - | Pslll (**r shift left logical long *) - | Psrll (**r shift right logical long *) - | Psrxl (**r shift right logical long round to 0*) - | Psral (**r shift right arithmetic long *) - - | Pfaddd (**r float add double *) - | Pfaddw (**r float add word *) - | Pfsbfd (**r float sub double *) - | Pfsbfw (**r float sub word *) - | Pfmuld (**r float multiply double *) - | Pfmulw (**r float multiply word *) - | Pfmind (**r float min double *) - | Pfminw (**r float min word *) - | Pfmaxd (**r float max double *) - | Pfmaxw (**r float max word *) -. - -Inductive arith_name_rri32 : Type := - | Pcompiw (it: itest) (**r comparison imm word *) - - | Paddiw (**r add imm word *) - | Paddxiw (shift : shift1_4) - | Prevsubiw (**r add imm word *) - | Prevsubxiw (shift : shift1_4) - | Pmuliw (**r add imm word *) - | Pandiw (**r and imm word *) - | Pnandiw (**r nand imm word *) - | Poriw (**r or imm word *) - | Pnoriw (**r nor imm word *) - | Pxoriw (**r xor imm word *) - | Pnxoriw (**r nxor imm word *) - | Pandniw (**r andn word *) - | Porniw (**r orn word *) - | Psraiw (**r shift right arithmetic imm word *) - | Psrxiw (**r shift right arithmetic imm word round to 0*) - | Psrliw (**r shift right logical imm word *) - | Pslliw (**r shift left logical imm word *) - | Proriw (**r rotate right imm word *) - | Psllil (**r shift left logical immediate long *) - | Psrlil (**r shift right logical immediate long *) - | Psrail (**r shift right arithmetic immediate long *) - | Psrxil (**r shift right arithmetic immediate long round to 0*) -. - -Inductive arith_name_rri64 : Type := - | Pcompil (it: itest) (**r comparison imm long *) - | Paddil (**r add immediate long *) - | Paddxil (shift : shift1_4) - | Prevsubil - | Prevsubxil (shift : shift1_4) - | Pmulil (**r mul immediate long *) - | Pandil (**r and immediate long *) - | Pnandil (**r nand immediate long *) - | Poril (**r or immediate long *) - | Pnoril (**r nor immediate long *) - | Pxoril (**r xor immediate long *) - | Pnxoril (**r nxor immediate long *) - | Pandnil (**r andn immediate long *) - | Pornil (**r orn immediate long *) -. - -Inductive arith_name_arrr : Type := - | Pmaddw (**r multiply add word *) - | Pmaddl (**r multiply add long *) - | Pmsubw (**r multiply subtract word *) - | Pmsubl (**r multiply subtract long *) - | Pcmove (bt: btest) (**r conditional move *) - | Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *) - | Pfmaddfw (**r float fused multiply add word *) - | Pfmaddfl (**r float fused multiply add long *) - | Pfmsubfw (**r float fused multiply subtract word *) - | Pfmsubfl (**r float fused multiply subtract long *) -. - -Inductive arith_name_arri32 : Type := - | Pmaddiw (**r multiply add word *) - | Pcmoveiw (bt: btest) - | Pcmoveuiw (bt: btest) -. - -Inductive arith_name_arri64 : Type := - | Pmaddil (**r multiply add long *) - | Pcmoveil (bt: btest) - | Pcmoveuil (bt: btest) -. - -Inductive arith_name_arr : Type := - | Pinsf (stop : Z) (start : Z) (**r insert bit field *) - | Pinsfl (stop : Z) (start : Z) (**r insert bit field *) -. - -Inductive ar_instruction : Type := - | PArithR (i: arith_name_r) (rd: ireg) - | PArithRR (i: arith_name_rr) (rd rs: ireg) - | PArithRI32 (i: arith_name_ri32) (rd: ireg) (imm: int) - | PArithRI64 (i: arith_name_ri64) (rd: ireg) (imm: int64) - | PArithRF32 (i: arith_name_rf32) (rd: ireg) (imm: float32) - | PArithRF64 (i: arith_name_rf64) (rd: ireg) (imm: float) - | PArithRRR (i: arith_name_rrr) (rd rs1 rs2: ireg) - | PArithRRI32 (i: arith_name_rri32) (rd rs: ireg) (imm: int) - | PArithRRI64 (i: arith_name_rri64) (rd rs: ireg) (imm: int64) - | PArithARRR (i: arith_name_arrr) (rd rs1 rs2: ireg) - | PArithARR (i: arith_name_arr) (rd rs: ireg) - | PArithARRI32 (i: arith_name_arri32) (rd rs: ireg) (imm: int) - | PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64) -. - -Module PArithCoercions. - -Coercion PArithR: arith_name_r >-> Funclass. -Coercion PArithRR: arith_name_rr >-> Funclass. -Coercion PArithRI32: arith_name_ri32 >-> Funclass. -Coercion PArithRI64: arith_name_ri64 >-> Funclass. -Coercion PArithRF32: arith_name_rf32 >-> Funclass. -Coercion PArithRF64: arith_name_rf64 >-> Funclass. -Coercion PArithRRR: arith_name_rrr >-> Funclass. -Coercion PArithRRI32: arith_name_rri32 >-> Funclass. -Coercion PArithRRI64: arith_name_rri64 >-> Funclass. -Coercion PArithARRR: arith_name_arrr >-> Funclass. -Coercion PArithARR: arith_name_arr >-> Funclass. -Coercion PArithARRI32: arith_name_arri32 >-> Funclass. -Coercion PArithARRI64: arith_name_arri64 >-> Funclass. - -End PArithCoercions. - -Inductive basic : Type := - | PArith (i: ar_instruction) - | PLoad (i: ld_instruction) - | PStore (i: st_instruction) - | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *) - | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *) - | Pget (rd: ireg) (rs: preg) (**r get system register *) - | Pset (rd: preg) (rs: ireg) (**r set system register *) - | Pnop (**r virtual instruction that does nothing *) -. - -Coercion PLoad: ld_instruction >-> basic. -Coercion PStore: st_instruction >-> basic. -Coercion PArith: ar_instruction >-> basic. - - -Inductive control : Type := - | PExpand (i: ex_instruction) - | PCtlFlow (i: cf_instruction) -. - -Coercion PExpand: ex_instruction >-> control. -Coercion PCtlFlow: cf_instruction >-> control. - - -(** * Definition of a bblock (ie a bundle) - -A bundle/bblock must contain at least one instruction. - -This choice simplifies the definition of [find_bblock] below: -indeed, each address of a code block identifies at most one bundle -(which depends on the number of instructions in the bundles of lower addresses). - -*) - -Definition non_empty_body (body: list basic): bool := - match body with - | nil => false - | _ => true - end. - -Definition non_empty_exit (exit: option control): bool := - match exit with - | None => false - | _ => true - end. - -Definition non_empty_bblockb (body: list basic) (exit: option control): bool := non_empty_body body || non_empty_exit exit. - - -(** TODO - * For now, we consider a builtin is alone in a bundle (and a basic block). - * Is there a way to avoid that ? - *) -Definition builtin_aloneb (body: list basic) (exit: option control) := - match exit with - | Some (PExpand (Pbuiltin _ _ _)) => - match body with - | nil => true - | _ => false - end - | _ => true - end. - -Definition wf_bblockb (body: list basic) (exit: option control) := - (non_empty_bblockb body exit) && (builtin_aloneb body exit). - -(** A bblock is well-formed if he contains at least one instruction, - and if there is a builtin then it must be alone in this bblock. *) - -Record bblock := mk_bblock { - header: list label; - body: list basic; - exit: option control; - correct: Is_true (wf_bblockb body exit) -}. - -(* FIXME? redundant with definition in Machblock *) -Definition length_opt {A} (o: option A) : nat := - match o with - | Some o => 1 - | None => 0 - end. - -(* WARNING: the notion of size is not the same than in Machblock ! - We ignore labels here... - - This notion of size induces the notion of "valid" code address given by [find_bblock] - - The result is in Z to be compatible with operations on PC. -*) -Definition size (b:bblock): Z := Z.of_nat (length (body b) + length_opt (exit b)). - -Definition bblocks := list bblock. - -Fixpoint size_blocks (l: bblocks): Z := - match l with - | nil => 0 - | b :: l => - (size b) + (size_blocks l) - end - . - -Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks }. -Definition fundef := AST.fundef function. -Definition program := AST.program fundef unit. - -(** * Operational semantics *) - -(** The semantics operates over a single mapping from registers - (type [preg]) to values. We maintain - the convention that integer registers are mapped to values of - type [Tint] or [Tlong] (in 64 bit mode), - and float registers to values of type [Tsingle] or [Tfloat]. *) - -Definition regset := Pregmap.t val. - -Definition genv := Genv.t fundef unit. - -Notation "a # b" := (a b) (at level 1, only parsing) : asm. -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm. - -Open Scope asm. - -(** Undefining some registers *) - -Fixpoint undef_regs (l: list preg) (rs: regset) : regset := - match l with - | nil => rs - | r :: l' => undef_regs l' (rs#r <- Vundef) - end. - - -(** Assigning a register pair *) -Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset := - match p with - | One r => rs#r <- v - | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v) - end. - - -(** Assigning the result of a builtin *) - -Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset := - match res with - | BR r => rs#r <- v - | BR_none => rs - | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs) - end. - -Local Open Scope asm. - -(** * Parallel Semantics of bundles *) - -Section RELSEM. - -(** Execution of arith instructions *) - -Variable ge: genv. - -(** The parallel semantics on bundles is purely small-step and defined as a relation - from the current state (a register set + a memory state) to either [Next rs' m'] - where [rs'] and [m'] are the updated register set and memory state after execution - of the instruction at [rs#PC], or [Stuck] if the processor is stuck. - - The parallel semantics of each instructions handles two states in input: - - the actual input state of the bundle which is only read - - and the other on which every "write" is performed: - it represents a temporary "writes" buffer, from which the final state - of the bundle is computed. - - NB: the sequential semantics defined in [Asmblock] is derived - from the parallel semantics of each instruction by identifying - the read state and the write state. - -*) - -Inductive outcome: Type := - | Next (rs:regset) (m:mem) - | Stuck -. - -(** ** Arithmetic Expressions (including comparisons) *) - -Inductive signedness: Type := Signed | Unsigned. - -Inductive intsize: Type := Int | Long. - -Definition itest_for_cmp (c: comparison) (s: signedness) := - match c, s with - | Cne, Signed => ITne - | Ceq, Signed => ITeq - | Clt, Signed => ITlt - | Cge, Signed => ITge - | Cle, Signed => ITle - | Cgt, Signed => ITgt - | Cne, Unsigned => ITneu - | Ceq, Unsigned => ITequ - | Clt, Unsigned => ITltu - | Cge, Unsigned => ITgeu - | Cle, Unsigned => ITleu - | Cgt, Unsigned => ITgtu - end. - -Inductive oporder_ftest := - | Normal (ft: ftest) - | Reversed (ft: ftest) -. - -Definition ftest_for_cmp (c: comparison) := - match c with - | Ceq => Normal FToeq - | Cne => Normal FTune - | Clt => Normal FTolt - | Cle => Reversed FToge - | Cgt => Reversed FTolt - | Cge => Normal FToge - end. - -Definition notftest_for_cmp (c: comparison) := - match c with - | Ceq => Normal FTune - | Cne => Normal FToeq - | Clt => Normal FTuge - | Cle => Reversed FTult - | Cgt => Reversed FTuge - | Cge => Normal FTult - end. - -(* CoMPare Signed Words to Zero *) -Definition btest_for_cmpswz (c: comparison) := - match c with - | Cne => BTwnez - | Ceq => BTweqz - | Clt => BTwltz - | Cge => BTwgez - | Cle => BTwlez - | Cgt => BTwgtz - end. - -(* CoMPare Signed Doubles to Zero *) -Definition btest_for_cmpsdz (c: comparison) := - match c with - | Cne => BTdnez - | Ceq => BTdeqz - | Clt => BTdltz - | Cge => BTdgez - | Cle => BTdlez - | Cgt => BTdgtz - end. - -Definition cmp_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTwltz => (Some Clt, Int) - | BTwgez => (Some Cge, Int) - | BTwlez => (Some Cle, Int) - | BTwgtz => (Some Cgt, Int) - - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | BTdltz => (Some Clt, Long) - | BTdgez => (Some Cge, Long) - | BTdlez => (Some Cle, Long) - | BTdgtz => (Some Cgt, Long) - end. - -Definition cmpu_for_btest (bt: btest) := - match bt with - | BTwnez => (Some Cne, Int) - | BTweqz => (Some Ceq, Int) - | BTdnez => (Some Cne, Long) - | BTdeqz => (Some Ceq, Long) - | _ => (None, Int) - end. - - -(* a few lemma on comparisons of unsigned (e.g. pointers) *) - -Definition Val_cmpu_bool cmp v1 v2: option bool := - Val.cmpu_bool (fun _ _ => true) cmp v1 v2. - -Lemma Val_cmpu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmpu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmpu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmpu cmp v1 v2 := Val.of_optbool (Val_cmpu_bool cmp v1 v2). - -Lemma Val_cmpu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.cmpu (Mem.valid_pointer m) cmp v1 v2) - (Val_cmpu cmp v1 v2). -Proof. - unfold Val.cmpu, Val_cmpu. - remember (Val.cmpu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob; simpl. - - erewrite Val_cmpu_bool_correct; eauto. - econstructor. - - econstructor. -Qed. - -Definition Val_cmplu_bool (cmp: comparison) (v1 v2: val) - := (Val.cmplu_bool (fun _ _ => true) cmp v1 v2). - -Lemma Val_cmplu_bool_correct (m:mem) (cmp: comparison) (v1 v2: val) b: - (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) = Some b - -> (Val_cmplu_bool cmp v1 v2) = Some b. -Proof. - intros; eapply Val.cmplu_bool_lessdef; (econstructor 1 || eauto). -Qed. - -Definition Val_cmplu cmp v1 v2 := Val.of_optbool (Val_cmplu_bool cmp v1 v2). - -Lemma Val_cmplu_correct (m:mem) (cmp: comparison) (v1 v2: val): - Val.lessdef (Val.maketotal (Val.cmplu (Mem.valid_pointer m) cmp v1 v2)) - (Val_cmplu cmp v1 v2). -Proof. - unfold Val.cmplu, Val_cmplu. - remember (Val.cmplu_bool (Mem.valid_pointer m) cmp v1 v2) as ob. - destruct ob as [b|]; simpl. - - erewrite Val_cmplu_bool_correct; eauto. - simpl. econstructor. - - econstructor. -Qed. - - - -(** Comparing integers *) -Definition compare_int (t: itest) (v1 v2: val): val := - match t with - | ITne => Val.cmp Cne v1 v2 - | ITeq => Val.cmp Ceq v1 v2 - | ITlt => Val.cmp Clt v1 v2 - | ITge => Val.cmp Cge v1 v2 - | ITle => Val.cmp Cle v1 v2 - | ITgt => Val.cmp Cgt v1 v2 - | ITneu => Val_cmpu Cne v1 v2 - | ITequ => Val_cmpu Ceq v1 v2 - | ITltu => Val_cmpu Clt v1 v2 - | ITgeu => Val_cmpu Cge v1 v2 - | ITleu => Val_cmpu Cle v1 v2 - | ITgtu => Val_cmpu Cgt v1 v2 - end. - -Definition compare_long (t: itest) (v1 v2: val): val := - let res := match t with - | ITne => Val.cmpl Cne v1 v2 - | ITeq => Val.cmpl Ceq v1 v2 - | ITlt => Val.cmpl Clt v1 v2 - | ITge => Val.cmpl Cge v1 v2 - | ITle => Val.cmpl Cle v1 v2 - | ITgt => Val.cmpl Cgt v1 v2 - | ITneu => Some (Val_cmplu Cne v1 v2) - | ITequ => Some (Val_cmplu Ceq v1 v2) - | ITltu => Some (Val_cmplu Clt v1 v2) - | ITgeu => Some (Val_cmplu Cge v1 v2) - | ITleu => Some (Val_cmplu Cle v1 v2) - | ITgtu => Some (Val_cmplu Cgt v1 v2) - end in - match res with - | Some v => v - | None => Vundef - end - . - -Definition compare_single (t: ftest) (v1 v2: val): val := - match t with - | FTone | FTueq => Vundef (* unused *) - | FToeq => Val.cmpfs Ceq v1 v2 - | FTune => Val.cmpfs Cne v1 v2 - | FTolt => Val.cmpfs Clt v1 v2 - | FTuge => Val.notbool (Val.cmpfs Clt v1 v2) - | FToge => Val.cmpfs Cge v1 v2 - | FTult => Val.notbool (Val.cmpfs Cge v1 v2) - end. - -Definition compare_float (t: ftest) (v1 v2: val): val := - match t with - | FTone | FTueq => Vundef (* unused *) - | FToeq => Val.cmpf Ceq v1 v2 - | FTune => Val.cmpf Cne v1 v2 - | FTolt => Val.cmpf Clt v1 v2 - | FTuge => Val.notbool (Val.cmpf Clt v1 v2) - | FToge => Val.cmpf Cge v1 v2 - | FTult => Val.notbool (Val.cmpf Cge v1 v2) - end. - -Definition arith_eval_r n := - match n with - | Ploadsymbol s ofs => Genv.symbol_address ge s ofs - end -. - -Definition arith_eval_rr n v := - match n with - | Pmv => v - | Pnegw => Val.neg v - | Pnegl => Val.negl v - | Pcvtl2w => Val.loword v - | Psxwd => Val.longofint v - | Pzxwd => Val.longofintu v - | Pextfz stop start => extfz stop start v - | Pextfs stop start => extfs stop start v - | Pextfzl stop start => extfzl stop start v - | Pextfsl stop start => extfsl stop start v - | Pfnegd => Val.negf v - | Pfnegw => Val.negfs v - | Pfabsd => Val.absf v - | Pfabsw => Val.absfs v - | Pfinvw => ExtValues.invfs v - | Pfnarrowdw => Val.singleoffloat v - | Pfwidenlwd => Val.floatofsingle v - | Pfloatwrnsz => Val.maketotal (Val.singleofint v) - | Pfloatuwrnsz => Val.maketotal (Val.singleofintu v) - | Pfloatudrnsz => Val.maketotal (Val.floatoflongu v) - | Pfloatdrnsz => Val.maketotal (Val.floatoflong v) - | Pfixedwrzz => Val.maketotal (Val.intofsingle v) - | Pfixeduwrzz => Val.maketotal (Val.intuofsingle v) - | Pfixeddrzz => Val.maketotal (Val.longoffloat v) - | Pfixedudrzz => Val.maketotal (Val.longuoffloat v) - | Pfixeddrzz_i32 => Val.maketotal (Val.intoffloat v) - | Pfixedudrzz_i32 => Val.maketotal (Val.intuoffloat v) - end. - -Definition arith_eval_ri32 n i := - match n with - | Pmake => Vint i - end. - -Definition arith_eval_ri64 n i := - match n with - | Pmakel => Vlong i - end. - -Definition arith_eval_rf32 n i := - match n with - | Pmakefs => Vsingle i - end. - -Definition arith_eval_rf64 n i := - match n with - | Pmakef => Vfloat i - end. - -Definition arith_eval_rrr n v1 v2 := - match n with - | Pcompw c => compare_int c v1 v2 - | Pcompl c => compare_long c v1 v2 - | Pfcompw c => compare_single c v1 v2 - | Pfcompl c => compare_float c v1 v2 - - | Paddw => Val.add v1 v2 - | Psubw => Val.sub v1 v2 - | Pmulw => Val.mul v1 v2 - | Pandw => Val.and v1 v2 - | Pnandw => Val.notint (Val.and v1 v2) - | Porw => Val.or v1 v2 - | Pnorw => Val.notint (Val.or v1 v2) - | Pxorw => Val.xor v1 v2 - | Pnxorw => Val.notint (Val.xor v1 v2) - | Pandnw => Val.and (Val.notint v1) v2 - | Pornw => Val.or (Val.notint v1) v2 - | Psrlw => Val.shru v1 v2 - | Psraw => Val.shr v1 v2 - | Psllw => Val.shl v1 v2 - | Psrxw => ExtValues.val_shrx v1 v2 - - | Paddl => Val.addl v1 v2 - | Psubl => Val.subl v1 v2 - | Pandl => Val.andl v1 v2 - | Pnandl => Val.notl (Val.andl v1 v2) - | Porl => Val.orl v1 v2 - | Pnorl => Val.notl (Val.orl v1 v2) - | Pxorl => Val.xorl v1 v2 - | Pnxorl => Val.notl (Val.xorl v1 v2) - | Pandnl => Val.andl (Val.notl v1) v2 - | Pornl => Val.orl (Val.notl v1) v2 - | Pmull => Val.mull v1 v2 - | Pslll => Val.shll v1 v2 - | Psrll => Val.shrlu v1 v2 - | Psral => Val.shrl v1 v2 - | Psrxl => ExtValues.val_shrxl v1 v2 - - | Pfaddd => Val.addf v1 v2 - | Pfaddw => Val.addfs v1 v2 - | Pfsbfd => Val.subf v1 v2 - | Pfsbfw => Val.subfs v1 v2 - | Pfmuld => Val.mulf v1 v2 - | Pfmulw => Val.mulfs v1 v2 - - | Pfmind => ExtValues.minf v1 v2 - | Pfminw => ExtValues.minfs v1 v2 - | Pfmaxd => ExtValues.maxf v1 v2 - | Pfmaxw => ExtValues.maxfs v1 v2 - - | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2 - | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2 - - | Prevsubxw shift => ExtValues.revsubx (int_of_shift1_4 shift) v1 v2 - | Prevsubxl shift => ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2 - end. - -Definition arith_eval_rri32 n v i := - match n with - | Pcompiw c => compare_int c v (Vint i) - | Paddiw => Val.add v (Vint i) - | Prevsubiw => Val.sub (Vint i) v - | Pmuliw => Val.mul v (Vint i) - | Pandiw => Val.and v (Vint i) - | Pnandiw => Val.notint (Val.and v (Vint i)) - | Poriw => Val.or v (Vint i) - | Pnoriw => Val.notint (Val.or v (Vint i)) - | Pxoriw => Val.xor v (Vint i) - | Pnxoriw => Val.notint (Val.xor v (Vint i)) - | Pandniw => Val.and (Val.notint v) (Vint i) - | Porniw => Val.or (Val.notint v) (Vint i) - | Psraiw => Val.shr v (Vint i) - | Psrxiw => ExtValues.val_shrx v (Vint i) - | Psrliw => Val.shru v (Vint i) - | Pslliw => Val.shl v (Vint i) - | Proriw => Val.ror v (Vint i) - | Psllil => Val.shll v (Vint i) - | Psrxil => ExtValues.val_shrxl v (Vint i) - | Psrlil => Val.shrlu v (Vint i) - | Psrail => Val.shrl v (Vint i) - | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i) - | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i) - end. - -Definition arith_eval_rri64 n v i := - match n with - | Pcompil c => compare_long c v (Vlong i) - | Paddil => Val.addl v (Vlong i) - | Prevsubil => Val.subl (Vlong i) v - | Pmulil => Val.mull v (Vlong i) - | Pandil => Val.andl v (Vlong i) - | Pnandil => Val.notl (Val.andl v (Vlong i)) - | Poril => Val.orl v (Vlong i) - | Pnoril => Val.notl (Val.orl v (Vlong i)) - | Pxoril => Val.xorl v (Vlong i) - | Pnxoril => Val.notl (Val.xorl v (Vlong i)) - | Pandnil => Val.andl (Val.notl v) (Vlong i) - | Pornil => Val.orl (Val.notl v) (Vlong i) - | Paddxil shift => ExtValues.addxl (int_of_shift1_4 shift) v (Vlong i) - | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i) - end. - -Definition cmove bt v1 v2 v3 := - match cmp_for_btest bt with - | (Some c, Int) => - match Val.cmp_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val.cmpl_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end. - -Definition cmoveu bt v1 v2 v3 := - match cmpu_for_btest bt with - | (Some c, Int) => - match Val_cmpu_bool c v2 (Vint Int.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (Some c, Long) => - match Val_cmplu_bool c v2 (Vlong Int64.zero) with - | None => Vundef - | Some true => v3 - | Some false => v1 - end - | (None, _) => Vundef - end. - -Definition arith_eval_arrr n v1 v2 v3 := - match n with - | Pmaddw => Val.add v1 (Val.mul v2 v3) - | Pmaddl => Val.addl v1 (Val.mull v2 v3) - | Pmsubw => Val.sub v1 (Val.mul v2 v3) - | Pmsubl => Val.subl v1 (Val.mull v2 v3) - | Pcmove bt => cmove bt v1 v2 v3 - | Pcmoveu bt => cmoveu bt v1 v2 v3 - | Pfmaddfw => ExtValues.fmaddfs v1 v2 v3 - | Pfmaddfl => ExtValues.fmaddf v1 v2 v3 - | Pfmsubfw => ExtValues.fmsubfs v1 v2 v3 - | Pfmsubfl => ExtValues.fmsubf v1 v2 v3 - end. - -Definition arith_eval_arr n v1 v2 := - match n with - | Pinsf stop start => ExtValues.insf stop start v1 v2 - | Pinsfl stop start => ExtValues.insfl stop start v1 v2 - end. - -Definition arith_eval_arri32 n v1 v2 v3 := - match n with - | Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3)) - | Pcmoveiw bt => cmove bt v1 v2 (Vint v3) - | Pcmoveuiw bt => cmoveu bt v1 v2 (Vint v3) - end. - -Definition arith_eval_arri64 n v1 v2 v3 := - match n with - | Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3)) - | Pcmoveil bt => cmove bt v1 v2 (Vlong v3) - | Pcmoveuil bt => cmoveu bt v1 v2 (Vlong v3) - end. - -Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset := - match ai with - | PArithR n d => rsw#d <- (arith_eval_r n) - - | PArithRR n d s => rsw#d <- (arith_eval_rr n rsr#s) - - | PArithRI32 n d i => rsw#d <- (arith_eval_ri32 n i) - | PArithRI64 n d i => rsw#d <- (arith_eval_ri64 n i) - | PArithRF32 n d i => rsw#d <- (arith_eval_rf32 n i) - | PArithRF64 n d i => rsw#d <- (arith_eval_rf64 n i) - - | PArithRRR n d s1 s2 => rsw#d <- (arith_eval_rrr n rsr#s1 rsr#s2) - | PArithRRI32 n d s i => rsw#d <- (arith_eval_rri32 n rsr#s i) - | PArithRRI64 n d s i => rsw#d <- (arith_eval_rri64 n rsr#s i) - - | PArithARRR n d s1 s2 => rsw#d <- (arith_eval_arrr n rsr#d rsr#s1 rsr#s2) - | PArithARR n d s => rsw#d <- (arith_eval_arr n rsr#d rsr#s) - | PArithARRI32 n d s i => rsw#d <- (arith_eval_arri32 n rsr#d rsr#s i) - | PArithARRI64 n d s i => rsw#d <- (arith_eval_arri64 n rsr#d rsr#s i) - end. - -Definition eval_offset (ofs: offset) : res ptrofs := OK ofs. - -(** * load/store *) - -Definition parexec_incorrect_load trap chunk d rsw mw := - match trap with - | TRAP => Stuck - | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw - end. - -Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) := - match (eval_offset ofs) with - | OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with - | None => parexec_incorrect_load trap chunk d rsw mw - | Some v => Next (rsw#d <- v) mw - end - | _ => Stuck - end. - -Definition parexec_load_q_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := - let (rd0, rd1) := gpreg_q_expand d in -(* NB: By construction of [gpreg_q], register rd0 and rd1 are distinct, thus, the register writes cannot overlap. - But we do not need to express/prove this in the semantics. -*) - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with - | None => Stuck - | Some v0 => - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with - | None => Stuck - | Some v1 => Next (rsw#rd0 <- v0 #rd1 <- v1) mw - end - end. - -Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a: ireg) (ofs: offset) := - match gpreg_o_expand d with - | (rd0, rd1, rd2, rd3) => -(* NB: By construction of [gpreg_o], the four destination registers are pairwise distinct, thus, the register writes cannot overlap. - But we do not need to express/prove this in the semantics. -*) - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) ofs) with - | None => Stuck - | Some v0 => - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) with - | None => Stuck - | Some v1 => - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) with - | None => Stuck - | Some v2 => - match Mem.loadv Many64 mr (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) with - | None => Stuck - | Some v3 => - Next (rsw#rd0 <- v0 #rd1 <- v1 #rd2 <- v2 #rd3 <- v3) mw - end - end - end - end - end. - -Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := - match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with - | None => parexec_incorrect_load trap chunk d rsw mw - | Some v => Next (rsw#d <- v) mw - end. - -Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) := - match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with - | None => parexec_incorrect_load trap chunk d rsw mw - | Some v => Next (rsw#d <- v) mw - end. - -Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a: ireg) (ofs: offset) := - match (eval_offset ofs) with - | OK ptr => match Mem.storev chunk mr (Val.offset_ptr (rsr a) ptr) (rsr s) with - | None => Stuck - | Some m' => Next rsw m' - end - | _ => Stuck - end. - -Definition parexec_store_reg - (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := - match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with - | None => Stuck - | Some m' => Next rsw m' - end. - -Definition parexec_store_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) := - match Mem.storev chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) (rsr s) with - | None => Stuck - | Some m' => Next rsw m' - end. - -Definition parexec_store_q_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_q) (a: ireg) (ofs: offset) := - let (s0, s1) := gpreg_q_expand s in - match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with - | None => Stuck - | Some m1 => - match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with - | None => Stuck - | Some m2 => Next rsw m2 - end - end. - -Definition parexec_store_o_offset (rsr rsw: regset) (mr mw: mem) (s : gpreg_o) (a: ireg) (ofs: offset) := - match gpreg_o_expand s with - | (s0, s1, s2, s3) => - match Mem.storev Many64 mr (Val.offset_ptr (rsr a) ofs) (rsr s0) with - | None => Stuck - | Some m1 => - match Mem.storev Many64 m1 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 8))) (rsr s1) with - | None => Stuck - | Some m2 => - match Mem.storev Many64 m2 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 16))) (rsr s2) with - | None => Stuck - | Some m3 => - match Mem.storev Many64 m3 (Val.offset_ptr (rsr a) (Ptrofs.add ofs (Ptrofs.repr 24))) (rsr s3) with - | None => Stuck - | Some m4 => Next rsw m4 - end - end - end - end - end. - - -Definition load_chunk n := - match n with - | Plb => Mint8signed - | Plbu => Mint8unsigned - | Plh => Mint16signed - | Plhu => Mint16unsigned - | Plw => Mint32 - | Plw_a => Many32 - | Pld => Mint64 - | Pld_a => Many64 - | Pfls => Mfloat32 - | Pfld => Mfloat64 - end. - -Definition store_chunk n := - match n with - | Psb => Mint8unsigned - | Psh => Mint16unsigned - | Psw => Mint32 - | Psw_a => Many32 - | Psd => Mint64 - | Psd_a => Many64 - | Pfss => Mfloat32 - | Pfsd => Mfloat64 - end. - -(** * basic instructions *) - -Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) := - match bi with - | PArith ai => Next (parexec_arith_instr ai rsr rsw) mw - - | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs - | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro - | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro - | PLoad (PLoadQRRO d a ofs) => - parexec_load_q_offset rsr rsw mr mw d a ofs - | PLoad (PLoadORRO d a ofs) => - parexec_load_o_offset rsr rsw mr mw d a ofs - - | PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs - | PStoreRRR n s a ro => parexec_store_reg (store_chunk n) rsr rsw mr mw s a ro - | PStoreRRRXS n s a ro => parexec_store_regxs (store_chunk n) rsr rsw mr mw s a ro - | PStoreQRRO s a ofs => - parexec_store_q_offset rsr rsw mr mw s a ofs - | PStoreORRO s a ofs => - parexec_store_o_offset rsr rsw mr mw s a ofs - - | Pallocframe sz pos => - let (mw, stk) := Mem.alloc mr 0 sz in - let sp := (Vptr stk Ptrofs.zero) in - match Mem.storev Mptr mw (Val.offset_ptr sp pos) rsr#SP with - | None => Stuck - | Some mw => Next (rsw #FP <- (rsr SP) #SP <- sp #RTMP <- Vundef) mw - end - - | Pfreeframe sz pos => - match Mem.loadv Mptr mr (Val.offset_ptr rsr#SP pos) with - | None => Stuck - | Some v => - match rsr SP with - | Vptr stk ofs => - match Mem.free mr stk 0 sz with - | None => Stuck - | Some mw => Next (rsw#SP <- v #RTMP <- Vundef) mw - end - | _ => Stuck - end - end - | Pget rd ra => - match ra with - | RA => Next (rsw#rd <- (rsr#ra)) mw - | _ => Stuck - end - | Pset ra rd => - match ra with - | RA => Next (rsw#ra <- (rsr#rd)) mw - | _ => Stuck - end - | Pnop => Next rsw mw -end. - -(* parexec with writes-in-order *) -Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) := - match body with - | nil => Next rsw mw - | bi::body' => - match bstep bi rsr rsw mr mw with - | Next rsw mw => parexec_wio_body body' rsr rsw mr mw - | Stuck => Stuck - end - end. - -(** TODO: redundant w.r.t Machblock ?? *) -Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. -Proof. - apply List.in_dec. - apply Pos.eq_dec. -Qed. - - - -(** Note: copy-paste from Machblock *) -Definition is_label (lbl: label) (bb: bblock) : bool := - if in_dec lbl (header bb) then true else false. - -Lemma is_label_correct_true lbl bb: - List.In lbl (header bb) <-> is_label lbl bb = true. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - -Lemma is_label_correct_false lbl bb: - ~(List.In lbl (header bb)) <-> is_label lbl bb = false. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - - - -(** convert a label into a position in the code *) -Fixpoint label_pos (lbl: label) (pos: Z) (lb: bblocks) {struct lb} : option Z := - match lb with - | nil => None - | b :: lb' => if is_label lbl b then Some pos else label_pos lbl (pos + (size b)) lb' - end. - -Definition par_goto_label (f: function) (lbl: label) (rsr rsw: regset) (mw: mem) := - match label_pos lbl 0 (fn_blocks f) with - | None => Stuck - | Some pos => - match rsr#PC with - | Vptr b ofs => Next (rsw#PC <- (Vptr b (Ptrofs.repr pos))) mw - | _ => Stuck - end - end. - -(** Evaluating a branch - -Warning: in m PC is assumed to be already pointing on the next instruction ! - -*) - -Definition par_eval_branch (f: function) (l: label) (rsr rsw: regset) (mw: mem) (res: option bool) := - match res with - | Some true => par_goto_label f l rsr rsw mw - | Some false => Next (rsw # PC <- (rsr PC)) mw - | None => Stuck - end. - - -(* FIXME: comment not up-to-date for parallel semantics *) - -(** Execution of a single control-flow instruction [i] in initial state [rs] and - [m]. Return updated state. - - As above: PC is assumed to be incremented on the next block before the control-flow instruction - - For instructions that correspond tobuiltin - actual RISC-V instructions, the cases are straightforward - transliterations of the informal descriptions given in the RISC-V - user-mode specification. For pseudo-instructions, refer to the - informal descriptions given above. - - Note that we set to [Vundef] the registers used as temporaries by - the expansions of the pseudo-instructions, so that the RISC-V code - we generate cannot use those registers to hold values that must - survive the execution of the pseudo-instruction. *) - -Definition parexec_control (f: function) (oc: option control) (rsr rsw: regset) (mw: mem) := - match oc with - | Some ic => -(** Get/Set system registers *) - match ic with - - -(** Branch Control Unit instructions *) - | Pret => - Next (rsw#PC <- (rsr#RA)) mw - | Pcall s => - Next (rsw#RA <- (rsr#PC) #PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw - | Picall r => - Next (rsw#RA <- (rsr#PC) #PC <- (rsr#r)) mw - | Pjumptable r tbl => - match rsr#r with - | Vint n => - match list_nth_z tbl (Int.unsigned n) with - | None => Stuck - | Some lbl => par_goto_label f lbl rsr (rsw #GPR62 <- Vundef #GPR63 <- Vundef) mw - end - | _ => Stuck - end - | Pgoto s => - Next (rsw#PC <- (Genv.symbol_address ge s Ptrofs.zero)) mw - | Pigoto r => - Next (rsw#PC <- (rsr#r)) mw - | Pj_l l => - par_goto_label f l rsr rsw mw - | Pcb bt r l => - match cmp_for_btest bt with - | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val.cmp_bool c rsr#r (Vint (Int.repr 0))) - | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val.cmpl_bool c rsr#r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - | Pcbu bt r l => - match cmpu_for_btest bt with - | (Some c, Int) => par_eval_branch f l rsr rsw mw (Val_cmpu_bool c rsr#r (Vint (Int.repr 0))) - | (Some c, Long) => par_eval_branch f l rsr rsw mw (Val_cmplu_bool c rsr#r (Vlong (Int64.repr 0))) - | (None, _) => Stuck - end - -(** Pseudo-instructions *) - | Pbuiltin ef args res => - Stuck (**r treated specially below *) - end - | None => Next (rsw#PC <- (rsr#PC)) mw -end. - - -Definition incrPC size_b (rs: regset) := - rs#PC <- (Val.offset_ptr rs#PC size_b). - -(** parallel execution of the exit instruction of a bundle *) -Definition estep (f: function) ext size_b (rsr rsw: regset) (mw: mem) - := parexec_control f ext (incrPC size_b rsr) rsw mw. - -Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome := - match parexec_wio_body bdy rs rs m m with - | Next rsw mw => estep f ext size_b rs rsw mw - | Stuck => Stuck - end. - -(** non-deterministic (out-of-order writes) parallel execution of bundles *) -Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) (o: outcome): Prop := - exists bdy1 bdy2, Permutation (bdy1++bdy2) (body bundle) /\ - o=match parexec_wio f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs m with - | Next rsw mw => parexec_wio_body bdy2 rs rsw m mw - | Stuck => Stuck - end. - -(** deterministic parallel (out-of-order writes) execution of bundles *) -Definition det_parexec (f: function) (bundle: bblock) (rs: regset) (m: mem) rs' m': Prop := - forall o, parexec_bblock f bundle rs m o -> o = Next rs' m'. - - -(* FIXME: comment not up-to-date *) -(** Translation of the LTL/Linear/Mach view of machine registers to - the RISC-V view. Note that no LTL register maps to [X31]. This - register is reserved as temporary, to be used by the generated RV32G - code. *) - - -(* FIXME - R16 and R32 are excluded *) -Definition preg_of (r: mreg) : preg := - match r with - | R0 => GPR0 | R1 => GPR1 | R2 => GPR2 | R3 => GPR3 | R4 => GPR4 - | R5 => GPR5 | R6 => GPR6 | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 - | R10 => GPR10 | R11 => GPR11 (* | R12 => GPR12 | R13 => GPR13 | R14 => GPR14 *) - | R15 => GPR15 (* | R16 => GPR16 *) | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 - | R20 => GPR20 | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 | R29 => GPR29 - | R30 => GPR30 | R31 => GPR31 (* | R32 => GPR32 *) | R33 => GPR33 | R34 => GPR34 - | R35 => GPR35 | R36 => GPR36 | R37 => GPR37 | R38 => GPR38 | R39 => GPR39 - | R40 => GPR40 | R41 => GPR41 | R42 => GPR42 | R43 => GPR43 | R44 => GPR44 - | R45 => GPR45 | R46 => GPR46 | R47 => GPR47 | R48 => GPR48 | R49 => GPR49 - | R50 => GPR50 | R51 => GPR51 | R52 => GPR52 | R53 => GPR53 | R54 => GPR54 - | R55 => GPR55 | R56 => GPR56 | R57 => GPR57 | R58 => GPR58 | R59 => GPR59 - | R60 => GPR60 | R61 => GPR61 | R62 => GPR62 | R63 => GPR63 - end. - -(** Undefine all registers except SP and callee-save registers *) - -Definition undef_caller_save_regs (rs: regset) : regset := - fun r => - if preg_eq r SP - || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs)) - then rs r - else Vundef. - -(* FIXME: comment not up-to-date *) -(** Extract the values of the arguments of an external call. - We exploit the calling conventions from module [Conventions], except that - we use RISC-V registers instead of locations. *) - -Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := - | extcall_arg_reg: forall r, - extcall_arg rs m (R r) (rs (preg_of r)) - | extcall_arg_stack: forall ofs ty bofs v, - bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> - Mem.loadv (chunk_of_type ty) m - (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v -> - extcall_arg rs m (S Outgoing ofs ty) v. - -Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop := - | extcall_arg_one: forall l v, - extcall_arg rs m l v -> - extcall_arg_pair rs m (One l) v - | extcall_arg_twolong: forall hi lo vhi vlo, - extcall_arg rs m hi vhi -> - extcall_arg rs m lo vlo -> - extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args. - - -Definition loc_external_result (sg: signature) : rpair preg := - map_rpair preg_of (loc_result sg). - - -(** Looking up bblocks in a code sequence by position. *) -Fixpoint find_bblock (pos: Z) (lb: bblocks) {struct lb} : option bblock := - match lb with - | nil => None - | b :: il => - if zlt pos 0 then None (* NOTE: It is impossible to branch inside a block *) - else if zeq pos 0 then Some b - else find_bblock (pos - (size b)) il - end. - - -Inductive state: Type := - | State: regset -> mem -> state. - -Definition nextblock (b:bblock) (rs: regset) := - incrPC (Ptrofs.repr (size b)) rs. - -Inductive step: state -> trace -> state -> Prop := - | exec_step_internal: - forall b ofs f bundle rs m rs' m', - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> - det_parexec f bundle rs m rs' m' -> - step (State rs m) E0 (State rs' m') - | exec_step_builtin: - forall b ofs f ef args res rs m vargs t vres rs' m' bi, - rs PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) f.(fn_blocks) = Some bi -> - exit bi = Some (PExpand (Pbuiltin ef args res)) -> - eval_builtin_args ge rs (rs SP) m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = nextblock bi - (set_res res vres - (undef_regs (map preg_of (destroyed_by_builtin ef)) - (rs#RTMP <- Vundef))) -> - step (State rs m) t (State rs' m') - | exec_step_external: - forall b ef args res rs m t rs' m', - rs PC = Vptr b Ptrofs.zero -> - Genv.find_funct_ptr ge b = Some (External ef) -> - external_call ef ge args m t res m' -> - extcall_arguments rs m (ef_sig ef) args -> - rs' = (set_pair (loc_external_result (ef_sig ef) ) res (undef_caller_save_regs rs))#PC <- (rs RA) -> - step (State rs m) t (State rs' m') - . - - -(** parallel in-order writes execution of bundles *) -Definition parexec_wio_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome := - parexec_wio f (body b) (exit b) (Ptrofs.repr (size b)) rs m. - - -Lemma parexec_bblock_write_in_order f b rs m: - parexec_bblock f b rs m (parexec_wio_bblock f b rs m). -Proof. - exists (body b). exists nil. - constructor 1. - - rewrite app_nil_r; auto. - - unfold parexec_wio_bblock. - destruct (parexec_wio f _ _ _); simpl; auto. -Qed. - - -Local Hint Resolve parexec_bblock_write_in_order: core. - -Lemma det_parexec_write_in_order f b rs m rs' m': - det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'. -Proof. - unfold det_parexec; auto. -Qed. - -End RELSEM. - -(** Execution of whole programs. *) - -(** Execution of whole programs. *) - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall m0, - let ge := Genv.globalenv p in - let rs0 := - (Pregmap.init Vundef) - # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero) - # SP <- Vnullptr - # RA <- Vnullptr in - Genv.init_mem p = Some m0 -> - initial_state p (State rs0 m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r, - rs PC = Vnullptr -> - rs GPR0 = Vint r -> - final_state (State rs m) r. - -Definition semantics (p: program) := - Semantics step (initial_state p) final_state (Genv.globalenv p). - -Remark extcall_arguments_determ: - forall rs m sg args1 args2, - extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2. -Proof. - intros until m. - assert (A: forall l v1 v2, - extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2). - { intros. inv H; inv H0; congruence. } - assert (B: forall p v1 v2, - extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2). - { intros. inv H; inv H0. - eapply A; eauto. - f_equal; eapply A; eauto. } - assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 -> - forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2). - { - induction 1; intros vl2 EA; inv EA. - auto. - f_equal; eauto. } - intros. eapply C; eauto. -Qed. - -Lemma semantics_determinate p: determinate (semantics p). -Proof. -Ltac Equalities := - match goal with - | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] => - rewrite H1 in H2; inv H2; Equalities - | _ => idtac - end. -Ltac Det_WIO X := - match goal with - | [ H: det_parexec _ _ _ _ _ _ _ |- _ ] => - exploit det_parexec_write_in_order; [ eapply H | idtac]; clear H; intro X - | _ => idtac - end. - intros; constructor; simpl. -- (* determ *) intros s t1 s1 t2 s2 H H0. inv H; Det_WIO X1; - inv H0; Det_WIO X2; Equalities. - + split. constructor. auto. - + unfold parexec_wio_bblock, parexec_wio in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. - rewrite H8 in X1. discriminate. - + unfold parexec_wio_bblock, parexec_wio in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate. - rewrite H4 in X2. discriminate. - + assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0. - exploit external_call_determ. eexact H6. eexact H13. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. - + assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0. - exploit external_call_determ. eexact H3. eexact H8. intros [A B]. - split. auto. intros. destruct B; auto. subst. auto. -- (* trace length *) - red; intros. inv H; simpl. - omega. - eapply external_call_trace_length; eauto. - eapply external_call_trace_length; eauto. -- (* initial states *) - intros s1 s2 H H0; inv H; inv H0; f_equal; congruence. -- (* final no step *) - intros s r H; assert (NOTNULL: forall b ofs, Vnullptr <> Vptr b ofs). - { intros; unfold Vnullptr; destruct Archi.ptr64; congruence. } - inv H. red; intros; red; intros. - inv H; rewrite H0 in *; eelim NOTNULL; eauto. -- (* final states *) - intros s r1 r2 H H0; inv H; inv H0. congruence. -Qed. diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v deleted file mode 100644 index eeb578d0..00000000 --- a/mppa_k1c/Builtins1.v +++ /dev/null @@ -1,66 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Platform-specific built-in functions *) - -Require Import String Coqlib. -Require Import AST Integers Floats Values ExtFloats. -Require Import Builtins0. - -Inductive platform_builtin : Type := -| BI_fmin -| BI_fmax -| BI_fminf -| BI_fmaxf -| BI_fabsf -| BI_fma -| BI_fmaf. - -Local Open Scope string_scope. - -Definition platform_builtin_table : list (string * platform_builtin) := - ("__builtin_fmin", BI_fmin) - :: ("__builtin_fmax", BI_fmax) - :: ("__builtin_fminf", BI_fminf) - :: ("__builtin_fmaxf", BI_fmaxf) - :: ("__builtin_fabsf", BI_fabsf) - :: ("__builtin_fma", BI_fma) - :: ("__builtin_fmaf", BI_fmaf) - :: nil. - -Definition platform_builtin_sig (b: platform_builtin) : signature := - match b with - | BI_fmin | BI_fmax => - mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default - | BI_fminf | BI_fmaxf => - mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default - | BI_fabsf => - mksignature (Tsingle :: nil) Tsingle cc_default - | BI_fma => - mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default - | BI_fmaf => - mksignature (Tsingle :: Tsingle :: Tsingle :: nil) Tsingle cc_default - end. - -Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := - match b with - | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min - | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max - | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min - | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max - | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs - | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma - | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma - end. diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml deleted file mode 100644 index 6dc3e938..00000000 --- a/mppa_k1c/CBuiltins.ml +++ /dev/null @@ -1,143 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(* Processor-dependent builtin C functions *) - -open C - -let builtins = { - builtin_typedefs = [ - "__builtin_va_list", TPtr(TVoid [], []) - ]; - (* The builtin list is inspired from the GCC file builtin_k1.h *) - builtin_functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *) - (* BCU Instructions *) - "__builtin_k1_await", (TVoid [], [], false); (* DONE *) - "__builtin_k1_barrier", (TVoid [], [], false); (* DONE *) - "__builtin_k1_doze", (TVoid [], [], false); (* opcode not supported in assembly, not in documentation *) - "__builtin_k1_wfxl", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) - "__builtin_k1_wfxm", (TVoid [], [TInt(IUChar, []); TInt(ILongLong, [])], false); (* DONE *) - "__builtin_k1_sleep", (TVoid [], [], false); (* DONE *) - "__builtin_k1_stop", (TVoid [], [], false); (* DONE *) - "__builtin_k1_syncgroup", (TVoid [], [TInt(IULongLong, [])], false); - "__builtin_k1_tlbread", (TVoid [], [], false); - "__builtin_k1_tlbwrite", (TVoid [], [], false); - "__builtin_k1_tlbprobe", (TVoid [], [], false); - "__builtin_k1_tlbdinval", (TVoid [], [], false); - "__builtin_k1_tlbiinval", (TVoid [], [], false); - - "__builtin_k1_get", (TInt(IULongLong, []), [TInt(IInt, [])], false); (* DONE *) - "__builtin_k1_set", (TVoid [], [TInt(IInt, []); TInt(IULongLong, [])], false); (* DONE *) - - (* LSU Instructions *) - (* acswapd and acswapw done using headers and assembly *) -(* "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false); - "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); *) (* see #157 *) - "__builtin_k1_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_dinval", (TVoid [], [], false); (* DONE *) - "__builtin_k1_dinvall", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_dtouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_dzerol", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_fence", (TVoid [], [], false); (* DONE *) - "__builtin_k1_iinval", (TVoid [], [], false); (* DONE *) - "__builtin_k1_iinvals", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_itouchl", (TVoid [], [TPtr(TVoid [], [])], false); (* DONE [not supported by assembler but in documentation] *) - "__builtin_k1_lbsu", (TInt(IChar, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_lbzu", (TInt(IUChar, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_ldu", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *) - "__builtin_k1_lhsu", (TInt(IShort, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_lhzu", (TInt(IUShort, []), [TPtr(TVoid [], [])], false); - "__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); - - (* ALU Instructions *) - (* "__builtin_k1_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) - (* "__builtin_k1_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) - (* "__builtin_k1_bwlu", (TInt(IUInt, []), - [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, []); TInt(IUShort, [])], false); *) - (* "__builtin_k1_bwluhp", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) - (* "__builtin_k1_bwluwp", (TInt(IULongLong, []), - [TInt(IULongLong, []); TInt(IULongLong, []); TInt(IUInt, [])], false); *) - (* "__builtin_k1_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - (* "__builtin_k1_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) - (* "__builtin_k1_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); - (* "__builtin_k1_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) - (* "__builtin_k1_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) - (* "__builtin_k1_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *) - "__builtin_k1_ctzw", (TInt(IInt, []), [TInt(IUInt, [])], false); - "__builtin_k1_ctzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); - (* "__builtin_k1_ctzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *) - (* "__builtin_k1_extfz", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, []); TInt(IUInt, [])], false); *) - (* "__builtin_k1_landhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *) - (* "__builtin_k1_sat", (TInt(IInt, []), [TInt(IInt, []); TInt(IUChar, [])], false); *) - "__builtin_k1_satd", (TInt(ILongLong, []), [TInt(ILongLong, []); TInt(IUChar, [])], false); - (* "__builtin_k1_sbfhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *) - "__builtin_k1_sbmm8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); - "__builtin_k1_sbmmt8", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); - (* "__builtin_k1_sllhps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) - (* "__builtin_k1_srahps", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) - (* "__builtin_k1_stsu", (TInt(IUInt, []), [TInt(IUInt, []); TInt(IUInt, [])], false); *) - "__builtin_k1_stsud", (TInt(IULongLong, []), [TInt(IULongLong, []); TInt(IULongLong, [])], false); - - - (* Synchronization *) -(* "__builtin_fence", - (TVoid [], [], false); *) -(* (* Float arithmetic *) - "__builtin_fmadd", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmsub", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fnmadd", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fnmsub", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *) - "__builtin_fabsf", - (TFloat(FFloat, []), - [TFloat(FFloat, [])], false); - "__builtin_fmax", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmin", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmaxf", - (TFloat(FFloat, []), - [TFloat(FFloat, []); TFloat(FFloat, [])], false); - "__builtin_fminf", - (TFloat(FFloat, []), - [TFloat(FFloat, []); TFloat(FFloat, [])], false); - "__builtin_fma", - (TFloat(FDouble, []), - [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); - "__builtin_fmaf", - (TFloat(FFloat, []), - [TFloat(FFloat, []); TFloat(FFloat, []); TFloat(FFloat, [])], false); -] -} - -let va_list_type = TPtr(TVoid [], []) (* to check! *) -let size_va_list = if Archi.ptr64 then 8 else 4 -let va_list_scalar = true - -(* Expand memory references inside extended asm statements. Used in C2C. *) - -let asm_mem_argument arg = Printf.sprintf "0(%s)" arg diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v deleted file mode 100644 index b4b80e2f..00000000 --- a/mppa_k1c/CSE2deps.v +++ /dev/null @@ -1,32 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* David Monniaux CNRS, VERIMAG *) -(* *) -(* Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import BoolEqual Coqlib. -Require Import AST Integers Floats. -Require Import Values Memory Globalenvs Events. -Require Import Op. - - -Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw := - (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk)) - && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk)) - && ((ofsw + size_chunk chunkw <=? ofsr) || - (ofsr + size_chunk chunkr <=? ofsw)). - -Definition may_overlap chunk addr args chunk' addr' args' := - match addr, addr', args, args' with - | (Aindexed ofs), (Aindexed ofs'), - (base :: nil), (base' :: nil) => - if peq base base' - then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk) - else true | _, _, _, _ => true - end. diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v deleted file mode 100644 index f283c8ac..00000000 --- a/mppa_k1c/CSE2depsproof.v +++ /dev/null @@ -1,139 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* David Monniaux CNRS, VERIMAG *) -(* *) -(* Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. -Require Import AST Linking. -Require Import Memory Registers Op RTL Maps. - -Require Import Globalenvs Values. -Require Import Linking Values Memory Globalenvs Events Smallstep. -Require Import Registers Op RTL. -Require Import CSE2 CSE2deps. -Require Import Lia. - -Lemma ptrofs_size : - Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat. -Proof. - unfold Ptrofs.wordsize. - unfold Wordsize_Ptrofs.wordsize. - trivial. -Qed. - -Lemma ptrofs_modulus : - Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296. -Proof. - unfold Ptrofs.modulus. - rewrite ptrofs_size. - destruct Archi.ptr64; reflexivity. -Qed. - -Section SOUNDNESS. - Variable F V : Type. - Variable genv: Genv.t F V. - Variable sp : val. - -Section MEMORY_WRITE. - Variable m m2 : mem. - Variable chunkw chunkr : memory_chunk. - Variable base : val. - - Variable addrw addrr valw : val. - Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2. - - Section INDEXED_AWAY. - Variable ofsw ofsr : ptrofs. - Hypothesis ADDRW : eval_addressing genv sp - (Aindexed ofsw) (base :: nil) = Some addrw. - Hypothesis ADDRR : eval_addressing genv sp - (Aindexed ofsr) (base :: nil) = Some addrr. - - Lemma load_store_away1 : - forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk, - forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk, - forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr - \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw, - Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. - - Proof. - intros. - - pose proof (max_size_chunk chunkr) as size_chunkr_bounded. - pose proof (max_size_chunk chunkw) as size_chunkw_bounded. - unfold largest_size_chunk in *. - - rewrite ptrofs_modulus in *. - simpl in *. - inv ADDRR. - inv ADDRW. - destruct base; try discriminate. - eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b). - exact STORE. - right. - - all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR]; - rewrite OFSR). - all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW]; - rewrite OFSW). - all: try rewrite ptrofs_modulus in *. - all: destruct Archi.ptr64. - - all: intuition lia. - Qed. - - Theorem load_store_away : - can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true -> - Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr. - Proof. - intro SWAP. - unfold can_swap_accesses_ofs in SWAP. - repeat rewrite andb_true_iff in SWAP. - repeat rewrite orb_true_iff in SWAP. - repeat rewrite Z.leb_le in SWAP. - apply load_store_away1. - all: tauto. - Qed. - End INDEXED_AWAY. -End MEMORY_WRITE. -End SOUNDNESS. - - -Section SOUNDNESS. - Variable F V : Type. - Variable genv: Genv.t F V. - Variable sp : val. - -Lemma may_overlap_sound: - forall m m' : mem, - forall chunk addr args chunk' addr' args' v a a' rs, - (eval_addressing genv sp addr (rs ## args)) = Some a -> - (eval_addressing genv sp addr' (rs ## args')) = Some a' -> - (may_overlap chunk addr args chunk' addr' args') = false -> - (Mem.storev chunk m a v) = Some m' -> - (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a'). -Proof. - intros until rs. - intros ADDR ADDR' OVERLAP STORE. - destruct addr; destruct addr'; try discriminate. - { (* Aindexed / Aindexed *) - destruct args as [ | base [ | ]]. 1,3: discriminate. - destruct args' as [ | base' [ | ]]. 1,3: discriminate. - simpl in OVERLAP. - destruct (peq base base'). 2: discriminate. - subst base'. - destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP. - 2: discriminate. - simpl in *. - eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption. - } -Qed. - -End SOUNDNESS. diff --git a/mppa_k1c/Chunks.v b/mppa_k1c/Chunks.v deleted file mode 100644 index 86d4f0ac..00000000 --- a/mppa_k1c/Chunks.v +++ /dev/null @@ -1,36 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import AST. -Require Import Values. -Require Import Integers. -Require Import Coq.ZArith.BinIntDef. -Require Import BinNums. - -Local Open Scope Z_scope. - -Definition zscale_of_chunk (chunk: memory_chunk) : Z := - match chunk with - | Mint8signed => 0 - | Mint8unsigned => 0 - | Mint16signed => 1 - | Mint16unsigned => 1 - | Mint32 => 2 - | Mint64 => 3 - | Mfloat32 => 2 - | Mfloat64 => 3 - | Many32 => 2 - | Many64 => 3 - end. -Definition scale_of_chunk chunk := Vint (Int.repr (zscale_of_chunk chunk)). diff --git a/mppa_k1c/CombineOp.v b/mppa_k1c/CombineOp.v deleted file mode 100644 index ff1db3cd..00000000 --- a/mppa_k1c/CombineOp.v +++ /dev/null @@ -1,141 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Recognition of combined operations, addressing modes and conditions - during the [CSE] phase. *) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Op. -Require Import CSEdomain. - -Section COMBINE. - -Variable get: valnum -> option rhs. - -Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) := - match get x with - | Some(Op (Ocmp c) ys) => Some (c, ys) - | _ => None - end. - -Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) := - match get x with - | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) - | _ => None - end. - -Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) := - match get x with - | Some(Op (Ocmp c) ys) => Some (c, ys) - | _ => None - end. - -Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) := - match get x with - | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys) - | _ => None - end. - -Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) := - match cond, args with - | Ccompimm Cne n, x::nil => - if Int.eq_dec n Int.zero then combine_compimm_ne_0 x - else if Int.eq_dec n Int.one then combine_compimm_ne_1 x - else None - | Ccompimm Ceq n, x::nil => - if Int.eq_dec n Int.zero then combine_compimm_eq_0 x - else if Int.eq_dec n Int.one then combine_compimm_eq_1 x - else None - | Ccompuimm Cne n, x::nil => - if Int.eq_dec n Int.zero then combine_compimm_ne_0 x - else if Int.eq_dec n Int.one then combine_compimm_ne_1 x - else None - | Ccompuimm Ceq n, x::nil => - if Int.eq_dec n Int.zero then combine_compimm_eq_0 x - else if Int.eq_dec n Int.one then combine_compimm_eq_1 x - else None - | _, _ => None - end. - -Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) := - match addr, args with - | Aindexed n, x::nil => - match get x with - | Some(Op (Oaddimm m) ys) => - if Archi.ptr64 then None else Some(Aindexed (Ptrofs.add (Ptrofs.of_int m) n), ys) - | Some(Op (Oaddlimm m) ys) => - if Archi.ptr64 then Some(Aindexed (Ptrofs.add (Ptrofs.of_int64 m) n), ys) else None - | _ => None - end - | _, _ => None - end. - -Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) := - match op, args with - | Oaddimm n, x :: nil => - match get x with - | Some(Op (Oaddimm m) ys) => Some(Oaddimm (Int.add m n), ys) - | _ => None - end - | Oandimm n, x :: nil => - match get x with - | Some(Op (Oandimm m) ys) => - Some(let p := Int.and m n in - if Int.eq p m then (Omove, x :: nil) else (Oandimm p, ys)) - | _ => None - end - | Oorimm n, x :: nil => - match get x with - | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys) - | _ => None - end - | Oxorimm n, x :: nil => - match get x with - | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys) - | _ => None - end - | Oaddlimm n, x :: nil => - match get x with - | Some(Op (Oaddlimm m) ys) => Some(Oaddlimm (Int64.add m n), ys) - | _ => None - end - | Oandlimm n, x :: nil => - match get x with - | Some(Op (Oandlimm m) ys) => - Some(let p := Int64.and m n in - if Int64.eq p m then (Omove, x :: nil) else (Oandlimm p, ys)) - | _ => None - end - | Oorlimm n, x :: nil => - match get x with - | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys) - | _ => None - end - | Oxorlimm n, x :: nil => - match get x with - | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys) - | _ => None - end - | Ocmp cond, _ => - match combine_cond cond args with - | Some(cond', args') => Some(Ocmp cond', args') - | None => None - end - | _, _ => None - end. - -End COMBINE. diff --git a/mppa_k1c/CombineOpproof.v b/mppa_k1c/CombineOpproof.v deleted file mode 100644 index dafc90df..00000000 --- a/mppa_k1c/CombineOpproof.v +++ /dev/null @@ -1,176 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Recognition of combined operations, addressing modes and conditions - during the [CSE] phase. *) - -Require Import FunInd. -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import CSEdomain. -Require Import CombineOp. - -Section COMBINE. - -Variable ge: genv. -Variable sp: val. -Variable m: mem. -Variable get: valnum -> option rhs. -Variable valu: valnum -> val. -Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v). - -Lemma get_op_sound: - forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v). -Proof. - intros. exploit get_sound; eauto. intros REV; inv REV; auto. -Qed. - -Ltac UseGetSound := - match goal with - | [ H: get _ = Some _ |- _ ] => - let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv) - end. - -Lemma combine_compimm_ne_0_sound: - forall x cond args, - combine_compimm_ne_0 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero). -Proof. - intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Lemma combine_compimm_eq_0_sound: - forall x cond args, - combine_compimm_eq_0 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero). -Proof. - intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - rewrite eval_negate_condition. - destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Lemma combine_compimm_eq_1_sound: - forall x cond args, - combine_compimm_eq_1 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one). -Proof. - intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Lemma combine_compimm_ne_1_sound: - forall x cond args, - combine_compimm_ne_1 get x = Some(cond, args) -> - eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\ - eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one). -Proof. - intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ. - (* of cmp *) - UseGetSound. rewrite <- H. - rewrite eval_negate_condition. - destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto. -Qed. - -Theorem combine_cond_sound: - forall cond args cond' args', - combine_cond get cond args = Some(cond', args') -> - eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m. -Proof. - intros. functional inversion H; subst. - (* compimm ne zero *) - - simpl; eapply combine_compimm_ne_0_sound; eauto. - (* compimm ne one *) - - simpl; eapply combine_compimm_ne_1_sound; eauto. - (* compimm eq zero *) - - simpl; eapply combine_compimm_eq_0_sound; eauto. - (* compimm eq one *) - - simpl; eapply combine_compimm_eq_1_sound; eauto. - (* compuimm ne zero *) - - simpl; eapply combine_compimm_ne_0_sound; eauto. - (* compuimm ne one *) - - simpl; eapply combine_compimm_ne_1_sound; eauto. - (* compuimm eq zero *) - - simpl; eapply combine_compimm_eq_0_sound; eauto. - (* compuimm eq one *) - - simpl; eapply combine_compimm_eq_1_sound; eauto. -Qed. - -Theorem combine_addr_sound: - forall addr args addr' args', - combine_addr get addr args = Some(addr', args') -> - eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args). -Proof. - intros. functional inversion H; subst. -- (* indexed - addimm *) - UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. - rewrite Ptrofs.add_assoc. auto. -- (* indexed - addimml *) - UseGetSound. simpl. rewrite <- H0. destruct v; auto. simpl; rewrite H7; simpl. - rewrite Ptrofs.add_assoc. auto. -Qed. - -Theorem combine_op_sound: - forall op args op' args', - combine_op get op args = Some(op', args') -> - eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m. -Proof. - intros. functional inversion H; subst. - (* addimm - addimm *) - - UseGetSound. FuncInv. simpl. - rewrite <- H0. rewrite Val.add_assoc. auto. - (* andimm - andimm *) - - UseGetSound; simpl. - generalize (Int.eq_spec p m0); rewrite H7; intros. - rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto. - - UseGetSound; simpl. - rewrite <- H0. rewrite Val.and_assoc. auto. - (* orimm - orimm *) - - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto. - (* xorimm - xorimm *) - - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto. - (* addlimm - addlimm *) - - UseGetSound. FuncInv. simpl. - rewrite <- H0. rewrite Val.addl_assoc. auto. - (* andlimm - andlimm *) - - UseGetSound; simpl. - generalize (Int64.eq_spec p m0); rewrite H7; intros. - rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto. - - UseGetSound; simpl. - rewrite <- H0. rewrite Val.andl_assoc. auto. - (* orlimm - orlimm *) - - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto. - (* xorlimm - xorlimm *) - - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto. - (* cmp *) - - simpl. decEq; decEq. eapply combine_cond_sound; eauto. -Qed. - -End COMBINE. diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp deleted file mode 100644 index 2a428020..00000000 --- a/mppa_k1c/ConstpropOp.vp +++ /dev/null @@ -1,312 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Strength reduction for operators and conditions. - This is the machine-dependent part of [Constprop]. *) - -Require Archi. -Require Import Coqlib Compopts. -Require Import AST Integers Floats. -Require Import Op Registers. -Require Import ValueDomain. - -(** * Converting known values to constants *) - -Definition const_for_result (a: aval) : option operation := - match a with - | I n => Some(Ointconst n) - | L n => if Archi.ptr64 then Some(Olongconst n) else None - | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None - | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None - | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs) - | Ptr(Stk ofs) => Some(Oaddrstack ofs) - | _ => None - end. - -(** * Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -Nondetfunction cond_strength_reduction - (cond: condition) (args: list reg) (vl: list aval) := - match cond, args, vl with - | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompimm (swap_comparison c) n1, r2 :: nil) - | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompimm c n2, r1 :: nil) - | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => - (Ccompuimm (swap_comparison c) n1, r2 :: nil) - | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => - (Ccompuimm c n2, r1 :: nil) - | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccomplimm (swap_comparison c) n1, r2 :: nil) - | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccomplimm c n2, r1 :: nil) - | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil => - (Ccompluimm (swap_comparison c) n1, r2 :: nil) - | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil => - (Ccompluimm c n2, r1 :: nil) - | _, _, _ => - (cond, args) - end. - -Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) := - let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args'). - -Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval) - (n: int) (r1: reg) (v1: aval) := - if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl. - -Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval) - (n: int) (r1: reg) (v1: aval) := - if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil) - else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil) - else make_cmp_base c args vl. - -Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) := - match c, args, vl with - | Ccompimm Ceq n, r1 :: nil, v1 :: nil => - make_cmp_imm_eq c args vl n r1 v1 - | Ccompimm Cne n, r1 :: nil, v1 :: nil => - make_cmp_imm_ne c args vl n r1 v1 - | Ccompuimm Ceq n, r1 :: nil, v1 :: nil => - make_cmp_imm_eq c args vl n r1 v1 - | Ccompuimm Cne n, r1 :: nil, v1 :: nil => - make_cmp_imm_ne c args vl n r1 v1 - | _, _, _ => - make_cmp_base c args vl - end. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oaddimm n, r :: nil). - -Definition make_shlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil) - else (Oshl, r1 :: r2 :: nil). - -Definition make_shrimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil) - else (Oshr, r1 :: r2 :: nil). - -Definition make_shruimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil) - else (Oshru, r1 :: r2 :: nil). - -Definition make_mulimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => (Oshlimm l, r1 :: nil) - | None => (Omul, r1 :: r2 :: nil) - end. - -Definition make_andimm (n: int) (r: reg) (a: aval) := - if Int.eq n Int.zero then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero - | _ => false end - then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else (Oxorimm n, r :: nil). - -Definition make_divimm n (r1 r2: reg) := - if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => if Int.ltu l (Int.repr 31) - then (Oshrximm l, r1 :: nil) - else (Odiv, r1 :: r2 :: nil) - | None => (Odiv, r1 :: r2 :: nil) - end. - -Definition make_divuimm n (r1 r2: reg) := - if Int.eq n Int.one then - (Omove, r1 :: nil) - else - match Int.is_power2 n with - | Some l => (Oshruimm l, r1 :: nil) - | None => (Odivu, r1 :: r2 :: nil) - end. - -Definition make_moduimm n (r1 r2: reg) := - match Int.is_power2 n with - | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil) - | None => (Omodu, r1 :: r2 :: nil) - end. - -Definition make_addlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero - then (Omove, r :: nil) - else (Oaddlimm n, r :: nil). - -Definition make_shllimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshllimm n, r1 :: nil) - else (Oshll, r1 :: r2 :: nil). - -Definition make_shrlimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrlimm n, r1 :: nil) - else (Oshrl, r1 :: r2 :: nil). - -Definition make_shrluimm (n: int) (r1 r2: reg) := - if Int.eq n Int.zero then (Omove, r1 :: nil) - else if Int.ltu n Int64.iwordsize' then (Oshrluimm n, r1 :: nil) - else (Oshrlu, r1 :: r2 :: nil). - -Definition make_mullimm (n: int64) (r1 r2: reg) := - if Int64.eq n Int64.zero then - (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.one then - (Omove, r1 :: nil) - else - match Int64.is_power2' n with - | Some l => (Oshllimm l, r1 :: nil) - | None => (Omull, r1 :: r2 :: nil) - end. - -Definition make_andlimm (n: int64) (r: reg) (a: aval) := - if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil) - else if Int64.eq n Int64.mone then (Omove, r :: nil) - else (Oandlimm n, r :: nil). - -Definition make_orlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil) - else (Oorlimm n, r :: nil). - -Definition make_xorlimm (n: int64) (r: reg) := - if Int64.eq n Int64.zero then (Omove, r :: nil) - else (Oxorlimm n, r :: nil). - -Definition make_divlimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => if Int.ltu l (Int.repr 63) - then (Oshrxlimm l, r1 :: nil) - else (Odivl, r1 :: r2 :: nil) - | None => (Odivl, r1 :: r2 :: nil) - end. - -Definition make_divluimm n (r1 r2: reg) := - match Int64.is_power2' n with - | Some l => (Oshrluimm l, r1 :: nil) - | None => (Odivlu, r1 :: r2 :: nil) - end. - -Definition make_modluimm n (r1 r2: reg) := - match Int64.is_power2 n with - | Some l => (Oandlimm (Int64.sub n Int64.one), r1 :: nil) - | None => (Omodlu, r1 :: r2 :: nil) - end. - -Definition make_mulfimm (n: float) (r r1 r2: reg) := - if Float.eq_dec n (Float.of_int (Int.repr 2)) - then (Oaddf, r :: r :: nil) - else (Omulf, r1 :: r2 :: nil). - -Definition make_mulfsimm (n: float32) (r r1 r2: reg) := - if Float32.eq_dec n (Float32.of_int (Int.repr 2)) - then (Oaddfs, r :: r :: nil) - else (Omulfs, r1 :: r2 :: nil). - -Definition make_cast8signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil). -Definition make_cast16signed (r: reg) (a: aval) := - if vincl a (Sgn Ptop 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil). - -Nondetfunction op_strength_reduction - (op: operation) (args: list reg) (vl: list aval) := - match op, args, vl with - | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1 - | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1 - | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2 - | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1 - | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1 - | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1 - | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2 - | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2 - | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2 - | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2 - | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2 - | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1 - | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1 - | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2 - | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1 - | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2 - | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1 - | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2 - | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2 - | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2 - | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2 - | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1 - | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1 - | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1 - | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2 - | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2 - | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2 - | Omodlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_modluimm n2 r1 r2 - | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2 - | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1 - | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1 - | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2 - | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1 - | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2 - | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1 - | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2 - | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2 - | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2 - | Ocmp c, args, vl => make_cmp c args vl - | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2 - | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2 - | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2 - | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2 - | _, _, _ => (op, args) - end. - -Nondetfunction addr_strength_reduction - (addr: addressing) (args: list reg) (vl: list aval) := - match addr, args, vl with - | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil => - if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) - then (addr, args) - else (Aglobal symb (Ptrofs.add n1 n), nil) - | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil => - (Ainstack (Ptrofs.add n1 n), nil) - | _, _, _ => - (addr, args) - end. - diff --git a/mppa_k1c/ConstpropOpproof.v b/mppa_k1c/ConstpropOpproof.v deleted file mode 100644 index 05bbdde1..00000000 --- a/mppa_k1c/ConstpropOpproof.v +++ /dev/null @@ -1,748 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Correctness proof for operator strength reduction. *) - -Require Import Coqlib Compopts. -Require Import Integers Floats Values Memory Globalenvs Events. -Require Import Op Registers RTL ValueDomain. -Require Import ConstpropOp. - -Section STRENGTH_REDUCTION. - -Variable bc: block_classification. -Variable ge: genv. -Hypothesis GENV: genv_match bc ge. -Variable sp: block. -Hypothesis STACK: bc sp = BCstack. -Variable ae: AE.t. -Variable e: regset. -Variable m: mem. -Hypothesis MATCH: ematch bc e ae. - -Lemma match_G: - forall r id ofs, - AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs). -Proof. - intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Lemma match_S: - forall r ofs, - AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs). -Proof. - intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH. -Qed. - -Ltac InvApproxRegs := - match goal with - | [ H: _ :: _ = _ :: _ |- _ ] => - injection H; clear H; intros; InvApproxRegs - | [ H: ?v = AE.get ?r ae |- _ ] => - generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs - | _ => idtac - end. - -Ltac SimplVM := - match goal with - | [ H: vmatch _ ?v (I ?n) |- _ ] => - let E := fresh in - assert (E: v = Vint n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (L ?n) |- _ ] => - let E := fresh in - assert (E: v = Vlong n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (F ?n) |- _ ] => - let E := fresh in - assert (E: v = Vfloat n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (FS ?n) |- _ ] => - let E := fresh in - assert (E: v = Vsingle n) by (inversion H; auto); - rewrite E in *; clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto); - clear H; SimplVM - | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] => - let E := fresh in - assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto); - clear H; SimplVM - | _ => idtac - end. - -Lemma const_for_result_correct: - forall a op v, - const_for_result a = Some op -> - vmatch bc v a -> - exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'. -Proof. - unfold const_for_result. generalize Archi.ptr64; intros ptr64; intros. - destruct a; inv H; SimplVM. -- (* integer *) - exists (Vint n); auto. -- (* long *) - destruct ptr64; inv H2. exists (Vlong n); auto. -- (* float *) - destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto. -- (* single *) - destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto. -- (* pointer *) - destruct p; try discriminate; SimplVM. - + (* global *) - inv H2. exists (Genv.symbol_address ge id ofs); auto. - + (* stack *) - inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto. -Qed. - -Lemma cond_strength_reduction_correct: - forall cond args vl, - vl = map (fun r => AE.get r ae) args -> - let (cond', args') := cond_strength_reduction cond args vl in - eval_condition cond' e##args' m = eval_condition cond e##args m. -Proof. - intros until vl. unfold cond_strength_reduction. - case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM. -- apply Val.swap_cmp_bool. -- auto. -- apply Val.swap_cmpu_bool. -- auto. -- apply Val.swap_cmpl_bool. -- auto. -- apply Val.swap_cmplu_bool. -- auto. -- auto. -Qed. - -Lemma make_cmp_base_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp_base c args vl in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros. unfold make_cmp_base. - generalize (cond_strength_reduction_correct c args vl H). - destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ. - econstructor; split. simpl; eauto. rewrite EQ. auto. -Qed. - -Lemma make_cmp_correct: - forall c args vl, - vl = map (fun r => AE.get r ae) args -> - let (op', args') := make_cmp c args vl in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v - /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v. -Proof. - intros c args vl. - assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true -> - e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one). - { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. } - unfold make_cmp. case (make_cmp_match c args vl); intros. -- unfold make_cmp_imm_eq. - destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. -+ simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. -* simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -* apply make_cmp_base_correct; auto. -- unfold make_cmp_imm_ne. - destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. -+ simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. -* simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -* apply make_cmp_base_correct; auto. -- unfold make_cmp_imm_eq. - destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. -+ simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. -* simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -* apply make_cmp_base_correct; auto. -- unfold make_cmp_imm_ne. - destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0. -+ simpl in H; inv H. InvBooleans. subst n. - exists (e#r1); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1. -* simpl in H; inv H. InvBooleans. subst n. - exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl. - exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto. -* apply make_cmp_base_correct; auto. -- apply make_cmp_base_correct; auto. -Qed. - -Lemma make_addimm_correct: - forall n r, - let (op, args) := make_addimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v. -Proof. - intros. unfold make_addimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst. exists (e#r); split; auto. - destruct (e#r); simpl; auto; rewrite ?Int.add_zero, ?Ptrofs.add_zero; auto. - exists (Val.add e#r (Vint n)); split; auto. -Qed. - -Lemma make_shlimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v. -Proof. - intros; unfold make_shlimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shrimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shrimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v. -Proof. - intros; unfold make_shrimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shruimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shruimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v. -Proof. - intros; unfold make_shruimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto. - destruct (Int.ltu n Int.iwordsize). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_mulimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_mulimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v. -Proof. - intros; unfold make_mulimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto. - destruct (Int.is_power2 n) eqn:?; intros. - rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto. auto. - econstructor; split; eauto. simpl. rewrite H; auto. -Qed. - -Lemma make_divimm_correct: - forall n r1 r2 v, - Val.divs e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - destruct (Int.ltu i (Int.repr 31)) eqn:?. - exists v; split; auto. simpl. - erewrite Val.divs_pow2; eauto. reflexivity. congruence. - exists v; auto. - exists v; auto. -Qed. - -Lemma make_divuimm_correct: - forall n r1 r2 v, - Val.divu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_divuimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divuimm. - predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H. - destruct (e#r1) eqn:?; - try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto); - inv H; auto. - destruct (Int.is_power2 n) eqn:?. - econstructor; split. simpl; eauto. - rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto. - exists v; auto. -Qed. - -Lemma make_moduimm_correct: - forall n r1 r2 v, - Val.modu e#r1 e#r2 = Some v -> - e#r2 = Vint n -> - let (op, args) := make_moduimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_moduimm. - destruct (Int.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence. - exists v; auto. -Qed. - -Lemma make_andimm_correct: - forall n r x, - vmatch bc e#r x -> - let (op, args) := make_andimm n r x in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v. -Proof. - intros; unfold make_andimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto. - destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero - | _ => false end) eqn:UNS. - destruct x; try congruence. - exists (e#r); split; auto. - inv H; auto. simpl. replace (Int.and i n) with i; auto. - generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ. - Int.bit_solve. destruct (zlt i0 n0). - replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)). - rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto. - rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto. - rewrite Int.bits_not by auto. apply negb_involutive. - rewrite H6 by auto. auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_orimm_correct: - forall n r, - let (op, args) := make_orimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v. -Proof. - intros; unfold make_orimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_xorimm_correct: - forall n r, - let (op, args) := make_xorimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v. -Proof. - intros; unfold make_xorimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto. - predSpec Int.eq Int.eq_spec n Int.mone; intros. - subst n. exists (Val.notint e#r); split; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_addlimm_correct: - forall n r, - let (op, args) := make_addlimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v. -Proof. - intros. unfold make_addlimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. - subst. exists (e#r); split; auto. - destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto. - exists (Val.addl e#r (Vlong n)); split; auto. -Qed. - -Lemma make_shllimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shllimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v. -Proof. - intros; unfold make_shllimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. - unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto. - destruct (Int.ltu n Int64.iwordsize'). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shrlimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shrlimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v. -Proof. - intros; unfold make_shrlimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. - unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto. - destruct (Int.ltu n Int64.iwordsize'). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_shrluimm_correct: - forall n r1 r2, - e#r2 = Vint n -> - let (op, args) := make_shrluimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v. -Proof. - intros; unfold make_shrluimm. - predSpec Int.eq Int.eq_spec n Int.zero; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. - unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto. - destruct (Int.ltu n Int64.iwordsize'). - econstructor; split. simpl. eauto. auto. - econstructor; split. simpl. eauto. rewrite H; auto. -Qed. - -Lemma make_mullimm_correct: - forall n r1 r2, - e#r2 = Vlong n -> - let (op, args) := make_mullimm n r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v. -Proof. - intros; unfold make_mullimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst. - exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst. - exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto. - destruct (Int64.is_power2' n) eqn:?; intros. - exists (Val.shll e#r1 (Vint i)); split; auto. - destruct (e#r1); simpl; auto. - erewrite Int64.is_power2'_range by eauto. - erewrite Int64.mul_pow2' by eauto. auto. - econstructor; split; eauto. simpl; rewrite H; auto. -Qed. - -Lemma make_divlimm_correct: - forall n r1 r2 v, - Val.divls e#r1 e#r2 = Some v -> - e#r2 = Vlong n -> - let (op, args) := make_divlimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divlimm. - destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?. - rewrite H0 in H. econstructor; split. simpl; eauto. - erewrite Val.divls_pow2; eauto. auto. - exists v; auto. - exists v; auto. -Qed. - -Lemma make_divluimm_correct: - forall n r1 r2 v, - Val.divlu e#r1 e#r2 = Some v -> - e#r2 = Vlong n -> - let (op, args) := make_divluimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_divluimm. - destruct (Int64.is_power2' n) eqn:?. - econstructor; split. simpl; eauto. - rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. - simpl. - erewrite Int64.is_power2'_range by eauto. - erewrite Int64.divu_pow2' by eauto. auto. - exists v; auto. -Qed. - -Lemma make_modluimm_correct: - forall n r1 r2 v, - Val.modlu e#r1 e#r2 = Some v -> - e#r2 = Vlong n -> - let (op, args) := make_modluimm n r1 r2 in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w. -Proof. - intros; unfold make_modluimm. - destruct (Int64.is_power2 n) eqn:?. - exists v; split; auto. simpl. decEq. - rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2. - simpl. erewrite Int64.modu_and by eauto. auto. - exists v; auto. -Qed. - -Lemma make_andlimm_correct: - forall n r x, - let (op, args) := make_andlimm n r x in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v. -Proof. - intros; unfold make_andlimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. - subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_orlimm_correct: - forall n r, - let (op, args) := make_orlimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v. -Proof. - intros; unfold make_orlimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. - subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_xorlimm_correct: - forall n r, - let (op, args) := make_xorlimm n r in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v. -Proof. - intros; unfold make_xorlimm. - predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. - subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone; intros. - subst n. exists (Val.notl e#r); split; auto. - econstructor; split; eauto. auto. -Qed. - -Lemma make_mulfimm_correct: - forall n r1 r2, - e#r2 = Vfloat n -> - let (op, args) := make_mulfimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. -Proof. - intros; unfold make_mulfimm. - destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfimm_correct_2: - forall n r1 r2, - e#r1 = Vfloat n -> - let (op, args) := make_mulfimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v. -Proof. - intros; unfold make_mulfimm. - destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto. - rewrite Float.mul_commut; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfsimm_correct: - forall n r1 r2, - e#r2 = Vsingle n -> - let (op, args) := make_mulfsimm n r1 r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. -Proof. - intros; unfold make_mulfsimm. - destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_mulfsimm_correct_2: - forall n r1 r2, - e#r1 = Vsingle n -> - let (op, args) := make_mulfsimm n r2 r1 r2 in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v. -Proof. - intros; unfold make_mulfsimm. - destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros. - simpl. econstructor; split. eauto. rewrite H; subst n. - destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto. - rewrite Float32.mul_commut; auto. - simpl. econstructor; split; eauto. -Qed. - -Lemma make_cast8signed_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast8signed r x in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 8 e#r) v. -Proof. - intros; unfold make_cast8signed. destruct (vincl x (Sgn Ptop 8)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Sgn Ptop 8)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma make_cast16signed_correct: - forall r x, - vmatch bc e#r x -> - let (op, args) := make_cast16signed r x in - exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext 16 e#r) v. -Proof. - intros; unfold make_cast16signed. destruct (vincl x (Sgn Ptop 16)) eqn:INCL. - exists e#r; split; auto. - assert (V: vmatch bc e#r (Sgn Ptop 16)). - { eapply vmatch_ge; eauto. apply vincl_ge; auto. } - inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto. - econstructor; split; simpl; eauto. -Qed. - -Lemma op_strength_reduction_correct: - forall op args vl v, - vl = map (fun r => AE.get r ae) args -> - eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v -> - let (op', args') := op_strength_reduction op args vl in - exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w. -Proof. - intros until v; unfold op_strength_reduction; - case (op_strength_reduction_match op args vl); simpl; intros. -- (* cast8signed *) - InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto. -- (* cast16signed *) - InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto. -- (* add 1 *) - rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. -- (* add 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto. -- (* sub *) - InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto. -- (* mul 1 *) - rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. -- (* mul 2*) - InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto. -- (* divs *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divimm_correct; auto. -- (* divu *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divuimm_correct; auto. -- (* modu *) - assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_moduimm_correct; auto. -- (* and 1 *) - rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. -- (* and 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto. -- (* andimm *) - inv H; inv H0. apply make_andimm_correct; auto. -- (* or 1 *) - rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. -- (* or 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto. -- (* xor 1 *) - rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. -- (* xor 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto. -- (* shl *) - InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto. -- (* shr *) - InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto. -- (* shru *) - InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto. -- (* addl 1 *) - rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. -- (* addl 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto. -- (* subl *) - InvApproxRegs; SimplVM; inv H0. - replace (Val.subl e#r1 (Vlong n2)) with (Val.addl e#r1 (Vlong (Int64.neg n2))). - apply make_addlimm_correct; auto. - unfold Val.addl, Val.subl. destruct Archi.ptr64 eqn:SF, e#r1; auto. - rewrite Int64.sub_add_opp; auto. - rewrite Ptrofs.sub_add_opp. do 2 f_equal. auto with ptrofs. - rewrite Int64.sub_add_opp; auto. -- (* mull 1 *) - rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. -- (* mull 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto. -- (* divl *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divlimm_correct; auto. -- (* divlu *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_divluimm_correct; auto. -- (* modlu *) - assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto. - apply make_modluimm_correct; auto. -- (* andl 1 *) - rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. -- (* andl 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto. -- (* andlimm *) - inv H; inv H0. apply make_andlimm_correct; auto. -- (* orl 1 *) - rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. -- (* orl 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto. -- (* xorl 1 *) - rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. -- (* xorl 2 *) - InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto. -- (* shll *) - InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto. -- (* shrl *) - InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto. -- (* shrlu *) - InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto. -- (* cond *) - inv H0. apply make_cmp_correct; auto. -- (* mulf 1 *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto. -- (* mulf 2 *) - InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2). - rewrite <- H2. apply make_mulfimm_correct_2; auto. -- (* mulfs 1 *) - InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto. -- (* mulfs 2 *) - InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2). - rewrite <- H2. apply make_mulfsimm_correct_2; auto. -- (* default *) - exists v; auto. -Qed. - -Lemma addr_strength_reduction_correct: - forall addr args vl res, - vl = map (fun r => AE.get r ae) args -> - eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res -> - let (addr', args') := addr_strength_reduction addr args vl in - exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'. -Proof. - intros until res. unfold addr_strength_reduction. - destruct (addr_strength_reduction_match addr args vl); simpl; - intros VL EA; InvApproxRegs; SimplVM; try (inv EA). -- destruct (orb _ _). -+ exists (Val.offset_ptr e#r1 n); auto. -+ simpl. rewrite Genv.shift_symbol_address. econstructor; split; eauto. - inv H0; simpl; auto. -- rewrite Ptrofs.add_zero_l. econstructor; split; eauto. - change (Vptr sp (Ptrofs.add n1 n)) with (Val.offset_ptr (Vptr sp n1) n). - inv H0; simpl; auto. -- exists res; auto. -Qed. - -End STRENGTH_REDUCTION. diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v deleted file mode 100644 index ab30ded9..00000000 --- a/mppa_k1c/Conventions1.v +++ /dev/null @@ -1,418 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Function calling conventions and other conventions regarding the use of - machine registers and stack slots. *) - -Require Import Coqlib Decidableplus. -Require Import AST Machregs Locations. - -(** * Classification of machine registers *) - -(** Machine registers (type [mreg] in module [Locations]) are divided in - the following groups: -- Callee-save registers, whose value is preserved across a function call. -- Caller-save registers that can be modified during a function call. - - We follow the RISC-V application binary interface (ABI) in our choice - of callee- and caller-save registers. -*) - -Definition is_callee_save (r: mreg) : bool := - match r with - (* | R15 | R16 | R17 *) | R18 | R19 | R20 | R21 | R22 - | R23 | R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true - | _ => false - end. - -Definition int_caller_save_regs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 - :: R10 :: R11 :: R15 (* :: R16 *) :: R17 - (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 :: R40 :: R41 - :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 :: R50 :: R51 - :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 :: R60 :: R61 - :: R62 :: R63 :: nil. - -Definition float_caller_save_regs : list mreg := nil. - -Definition int_callee_save_regs := - (* R15 :: R16 :: R17 :: *)R18 :: R19 :: R20 :: R21 :: R22 - :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. - -Definition float_callee_save_regs : list mreg := nil. - -Definition destroyed_at_call := - List.filter (fun r => negb (is_callee_save r)) all_mregs. - -Definition dummy_int_reg := R63. (**r Used in [Coloring]. *) -Definition dummy_float_reg := R62. (**r Used in [Coloring]. *) - -Definition callee_save_type := mreg_type. - -Definition is_float_reg (r: mreg) := false. - -(** * Function calling conventions *) - -(** The functions in this section determine the locations (machine registers - and stack slots) used to communicate arguments and results between the - caller and the callee during function calls. These locations are functions - of the signature of the function and of the call instruction. - Agreement between the caller and the callee on the locations to use - is guaranteed by our dynamic semantics for Cminor and RTL, which demand - that the signature of the call instruction is identical to that of the - called function. - - Calling conventions are largely arbitrary: they must respect the properties - proved in this section (such as no overlapping between the locations - of function arguments), but this leaves much liberty in choosing actual - locations. To ensure binary interoperability of code generated by our - compiler with libraries compiled by another compiler, we - implement the standard RISC-V conventions. *) - -(** ** Location of function result *) - -(** The result value of a function is passed back to the caller in - registers [R10] or [F10] or [R10,R11], depending on the type of the - returned value. We treat a function without result as a function - with one integer result. *) - - -Definition loc_result (s: signature) : rpair mreg := - match s.(sig_res) with - | Tvoid => One R0 - | Tint8signed => One R0 - | Tint8unsigned => One R0 - | Tint16signed => One R0 - | Tint16unsigned => One R0 - | Tint | Tany32 => One R0 - | Tfloat | Tsingle | Tany64 => One R0 - | Tlong => if Archi.ptr64 then One R0 else One R0 - end. - -(** The result registers have types compatible with that given in the signature. *) - -Lemma loc_result_type: - forall sig, - subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true. -Proof. - intros. unfold proj_sig_res, loc_result, mreg_type. - destruct (sig_res sig); try destruct Archi.ptr64; simpl; trivial; destruct t; trivial. -Qed. - -(** The result locations are caller-save registers *) - -Lemma loc_result_caller_save: - forall (s: signature), - forall_rpair (fun r => is_callee_save r = false) (loc_result s). -Proof. - intros. unfold loc_result, is_callee_save; - destruct (sig_res s); simpl; auto; try destruct Archi.ptr64; simpl; auto; try destruct t; simpl; auto. -Qed. - -(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *) - -Lemma loc_result_pair: - forall sg, - match loc_result sg with - | One _ => True - | Twolong r1 r2 => - r1 <> r2 /\ proj_sig_res sg = Tlong - /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true - /\ Archi.ptr64 = false - end. -Proof. - intros. - unfold loc_result; destruct (sig_res sg); auto; - unfold mreg_type; try destruct Archi.ptr64; auto; - destruct t; auto. -Qed. - -(** The location of the result depends only on the result part of the signature *) - -Lemma loc_result_exten: - forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2. -Proof. - intros. unfold loc_result. rewrite H; auto. -Qed. - -(** ** Location of function arguments *) - -(** The RISC-V ABI states the following convention for passing arguments - to a function: - -- Arguments are passed in registers when possible. - -- Up to eight integer registers (ai: int_param_regs) and up to eight - floating-point registers (fai: float_param_regs) are used for this - purpose. - -- If the arguments to a function are conceptualized as fields of a C - struct, each with pointer alignment, the argument registers are a - shadow of the first eight pointer-words of that struct. If argument - i < 8 is a floating-point type, it is passed in floating-point - register fa_i; otherwise, it is passed in integer register a_i. - -- When primitive arguments twice the size of a pointer-word are passed - on the stack, they are naturally aligned. When they are passed in the - integer registers, they reside in an aligned even-odd register pair, - with the even register holding the least-significant bits. - -- Floating-point arguments to variadic functions (except those that - are explicitly named in the parameter list) are passed in integer - registers. - -- The portion of the conceptual struct that is not passed in argument - registers is passed on the stack. The stack pointer sp points to the - first argument not passed in a register. - -The bit about variadic functions doesn't quite fit CompCert's model. -We do our best by passing the FP arguments in registers, as usual, -and reserving the corresponding integer registers, so that fixup -code can be introduced in the Asmexpand pass. -*) - -Definition param_regs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: nil. - -Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) - (rec: Z -> Z -> list (rpair loc)) := - match list_nth_z regs rn with - | Some r => - One(R r) :: rec (rn + 1) ofs - | None => - let ofs := align ofs (typealign ty) in - One(S Outgoing ofs ty) :: rec rn (ofs + (if Archi.ptr64 then 2 else typesize ty)) - end. - -Definition two_args (regs: list mreg) (rn: Z) (ofs: Z) - (rec: Z -> Z -> list (rpair loc)) := - let rn := align rn 2 in - match list_nth_z regs rn, list_nth_z regs (rn + 1) with - | Some r1, Some r2 => - Twolong (R r2) (R r1) :: rec (rn + 2) ofs - | _, _ => - let ofs := align ofs 2 in - Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) :: - rec rn (ofs + 2) - end. - -Definition hybrid_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ) - (rec: Z -> Z -> list (rpair loc)) := - let rn := align rn 2 in - match list_nth_z regs rn with - | Some r => - One (R r) :: rec (rn + 2) ofs - | None => - let ofs := align ofs 2 in - One (S Outgoing ofs ty) :: rec rn (ofs + 2) - end. - -Fixpoint loc_arguments_rec (va: bool) - (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) := - match tyl with - | nil => nil - | ty :: tys => one_arg param_regs r ofs ty (loc_arguments_rec va tys) -(* - | (Tint | Tany32) as ty :: tys => - one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) - | Tsingle as ty :: tys => - one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) - | Tlong as ty :: tys => - if Archi.ptr64 - then one_arg int_param_regs r ofs ty (loc_arguments_rec va tys) - else two_args int_param_regs r ofs (loc_arguments_rec va tys) - | (Tfloat | Tany64) as ty :: tys => - if va && negb Archi.ptr64 - then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys) - else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys) -*) - end. - -(** [loc_arguments s] returns the list of locations where to store arguments - when calling a function with signature [s]. *) - -Definition loc_arguments (s: signature) : list (rpair loc) := - loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0. - -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Definition max_outgoing_1 (accu: Z) (l: loc) : Z := - match l with - | S Outgoing ofs ty => Z.max accu (ofs + typesize ty) - | _ => accu - end. - -Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z := - match rl with - | One l => max_outgoing_1 accu l - | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2 - end. - -Definition size_arguments (s: signature) : Z := - List.fold_left max_outgoing_2 (loc_arguments s) 0. - -(** Argument locations are either non-temporary registers or [Outgoing] - stack slots at nonnegative offsets. *) - -Definition loc_argument_acceptable (l: loc) : Prop := - match l with - | R r => is_callee_save r = false - | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs) - | _ => False - end. - -Lemma loc_arguments_rec_charact: - forall va tyl rn ofs p, - ofs >= 0 -> - In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p. -Proof. - set (OK := fun (l: list (rpair loc)) => - forall p, In p l -> forall_rpair loc_argument_acceptable p). - set (OKF := fun (f: Z -> Z -> list (rpair loc)) => - forall rn ofs, ofs >= 0 -> OK (f rn ofs)). - set (OKREGS := fun (l: list mreg) => forall r, In r l -> is_callee_save r = false). - assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0). - { intros. - assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos). - omega. } - assert (SK: (if Archi.ptr64 then 2 else 1) > 0). - { destruct Archi.ptr64; omega. } - assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0). - { intros. destruct Archi.ptr64. omega. apply typesize_pos. } - assert (A: forall regs rn ofs ty f, - OKREGS regs -> OKF f -> ofs >= 0 -> OK (one_arg regs rn ofs ty f)). - { intros until f; intros OR OF OO; red; unfold one_arg; intros. - destruct (list_nth_z regs rn) as [r|] eqn:NTH; destruct H. - - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. - - eapply OF; eauto. - - subst p; simpl. auto using align_divides, typealign_pos. - - eapply OF; [idtac|eauto]. - generalize (AL ofs ty OO) (SKK ty); omega. - } - assert (B: forall regs rn ofs f, - OKREGS regs -> OKF f -> ofs >= 0 -> OK (two_args regs rn ofs f)). - { intros until f; intros OR OF OO; unfold two_args. - set (rn' := align rn 2). - set (ofs' := align ofs 2). - assert (OO': ofs' >= 0) by (apply (AL ofs Tlong); auto). - assert (DFL: OK (Twolong (S Outgoing (ofs' + 1) Tint) (S Outgoing ofs' Tint) - :: f rn' (ofs' + 2))). - { red; simpl; intros. destruct H. - - subst p; simpl. - repeat split; auto using Z.divide_1_l. omega. - - eapply OF; [idtac|eauto]. omega. - } - destruct (list_nth_z regs rn') as [r1|] eqn:NTH1; - destruct (list_nth_z regs (rn' + 1)) as [r2|] eqn:NTH2; - try apply DFL. - red; simpl; intros; destruct H. - - subst p; simpl. split; apply OR; eauto using list_nth_z_in. - - eapply OF; [idtac|eauto]. auto. - } - assert (C: forall regs rn ofs ty f, - OKREGS regs -> OKF f -> ofs >= 0 -> typealign ty = 1 -> OK (hybrid_arg regs rn ofs ty f)). - { intros until f; intros OR OF OO OTY; unfold hybrid_arg; red; intros. - set (rn' := align rn 2) in *. - destruct (list_nth_z regs rn') as [r|] eqn:NTH; destruct H. - - subst p; simpl. apply OR. eapply list_nth_z_in; eauto. - - eapply OF; eauto. - - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l. - - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega. - } - assert (D: OKREGS param_regs). - { red. decide_goal. } - assert (E: OKREGS param_regs). - { red. decide_goal. } - - cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)). - unfold OK. eauto. - induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl. - - red; simpl; tauto. - - destruct ty1. -+ (* int *) apply A; auto. -+ (* float *) - apply A; auto. -+ (* long *) - apply A; auto. -+ (* single *) - apply A; auto. -+ (* any32 *) - apply A; auto. -+ (* any64 *) - apply A; auto. -Qed. - -Lemma loc_arguments_acceptable: - forall (s: signature) (p: rpair loc), - In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p. -Proof. - unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega. -Qed. - -(** The offsets of [Outgoing] arguments are below [size_arguments s]. *) - -Remark fold_max_outgoing_above: - forall l n, fold_left max_outgoing_2 l n >= n. -Proof. - assert (A: forall n l, max_outgoing_1 n l >= n). - { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } - induction l; simpl; intros. - - omega. - - eapply Zge_trans. eauto. - destruct a; simpl. apply A. eapply Zge_trans; eauto. -Qed. - -Lemma size_arguments_above: - forall s, size_arguments s >= 0. -Proof. - intros. apply fold_max_outgoing_above. -Qed. - -Lemma loc_arguments_bounded: - forall (s: signature) (ofs: Z) (ty: typ), - In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) -> - ofs + typesize ty <= size_arguments s. -Proof. - intros until ty. - assert (A: forall n l, n <= max_outgoing_1 n l). - { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. } - assert (B: forall p n, - In (S Outgoing ofs ty) (regs_of_rpair p) -> - ofs + typesize ty <= max_outgoing_2 n p). - { intros. destruct p; simpl in H; intuition; subst; simpl. - - xomega. - - eapply Z.le_trans. 2: apply A. xomega. - - xomega. } - assert (C: forall l n, - In (S Outgoing ofs ty) (regs_of_rpairs l) -> - ofs + typesize ty <= fold_left max_outgoing_2 l n). - { induction l; simpl; intros. - - contradiction. - - rewrite in_app_iff in H. destruct H. - + eapply Z.le_trans. eapply B; eauto. apply Z.ge_le. apply fold_max_outgoing_above. - + apply IHl; auto. - } - apply C. -Qed. - -Lemma loc_arguments_main: - loc_arguments signature_main = nil. -Proof. - reflexivity. -Qed. - - -Definition return_value_needs_normalization (t: rettype) : bool := false. diff --git a/mppa_k1c/DecBoolOps.v b/mppa_k1c/DecBoolOps.v deleted file mode 100644 index 1e0a6187..00000000 --- a/mppa_k1c/DecBoolOps.v +++ /dev/null @@ -1,30 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Set Implicit Arguments. - -Theorem and_dec : forall A B C D : Prop, - { A } + { B } -> { C } + { D } -> - { A /\ C } + { (B /\ C) \/ (B /\ D) \/ (A /\ D) }. -Proof. - intros A B C D AB CD. - destruct AB; destruct CD. - - left. tauto. - - right. tauto. - - right. tauto. - - right. tauto. -Qed. - - diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml deleted file mode 100644 index 38702e1b..00000000 --- a/mppa_k1c/DuplicateOpcodeHeuristic.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(* open Camlcoq *) -open Op -open Integers - -let opcode_heuristic code cond ifso ifnot is_loop_header = - match cond with - | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with - | Clt | Cle -> Some false - | Cgt | Cge -> Some true - | _ -> None - ) else None - | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with - | Clt | Cle -> Some false - | Cgt | Cge -> Some true - | _ -> None - ) else None - | Ccompf c | Ccompfs c -> (match c with - | Ceq -> Some false - | Cne -> Some true - | _ -> None - ) - | Cnotcompf c | Cnotcompfs c -> (match c with - | Ceq -> Some true - | Cne -> Some false - | _ -> None - ) - | _ -> None diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v deleted file mode 100644 index 9849c35d..00000000 --- a/mppa_k1c/ExtFloats.v +++ /dev/null @@ -1,54 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Floats Integers ZArith. - -Module ExtFloat. -(** TODO check with the actual K1c; - this is what happens on x86 and may be inappropriate. *) - -Definition min (x : float) (y : float) : float := - match Float.compare x y with - | Some Eq | Some Lt => x - | Some Gt | None => y - end. - -Definition max (x : float) (y : float) : float := - match Float.compare x y with - | Some Eq | Some Gt => x - | Some Lt | None => y - end. -End ExtFloat. - -Module ExtFloat32. -(** TODO check with the actual K1c *) - -Definition min (x : float32) (y : float32) : float32 := - match Float32.compare x y with - | Some Eq | Some Lt => x - | Some Gt | None => y - end. - -Definition max (x : float32) (y : float32) : float32 := - match Float32.compare x y with - | Some Eq | Some Gt => x - | Some Lt | None => y - end. - -Definition one := Float32.of_int (Int.repr (1%Z)). -Definition inv (x : float32) : float32 := - Float32.div one x. - -End ExtFloat32. diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v deleted file mode 100644 index 3664c00a..00000000 --- a/mppa_k1c/ExtValues.v +++ /dev/null @@ -1,755 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import Integers. -Require Import Values. -Require Import Floats ExtFloats. - -Open Scope Z_scope. - -Definition abs_diff (x y : Z) := Z.abs (x - y). -Definition abs_diff2 (x y : Z) := - if x <=? y then y - x else x - y. -Lemma abs_diff2_correct : - forall x y : Z, (abs_diff x y) = (abs_diff2 x y). -Proof. - intros. - unfold abs_diff, abs_diff2. - unfold Z.leb. - pose proof (Z.compare_spec x y) as Hspec. - inv Hspec. - - rewrite Z.abs_eq; omega. - - rewrite Z.abs_neq; omega. - - rewrite Z.abs_eq; omega. -Qed. - -Inductive shift1_4 : Type := -| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4. - -Definition z_of_shift1_4 (x : shift1_4) := - match x with - | SHIFT1 => 1 - | SHIFT2 => 2 - | SHIFT3 => 3 - | SHIFT4 => 4 - end. - -Definition shift1_4_of_z (x : Z) := - if Z.eq_dec x 1 then Some SHIFT1 - else if Z.eq_dec x 2 then Some SHIFT2 - else if Z.eq_dec x 3 then Some SHIFT3 - else if Z.eq_dec x 4 then Some SHIFT4 - else None. - -Lemma shift1_4_of_z_correct : - forall z, - match shift1_4_of_z z with - | Some x => z_of_shift1_4 x = z - | None => True - end. -Proof. - intro. unfold shift1_4_of_z. - destruct (Z.eq_dec _ _); simpl; try congruence. - destruct (Z.eq_dec _ _); simpl; try congruence. - destruct (Z.eq_dec _ _); simpl; try congruence. - destruct (Z.eq_dec _ _); simpl; try congruence. - trivial. -Qed. - -Definition int_of_shift1_4 (x : shift1_4) := - Int.repr (z_of_shift1_4 x). - -Definition is_bitfield stop start := - (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int.zwordsize). - -Definition extfz stop start v := - if is_bitfield stop start - then - let stop' := Z.add stop Z.one in - match v with - | Vint w => - Vint (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) - | _ => Vundef - end - else Vundef. - - -Definition extfs stop start v := - if is_bitfield stop start - then - let stop' := Z.add stop Z.one in - match v with - | Vint w => - Vint (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) - | _ => Vundef - end - else Vundef. - -Definition zbitfield_mask stop start := - (Z.shiftl 1 (Z.succ stop)) - (Z.shiftl 1 start). - -Definition bitfield_mask stop start := - Vint(Int.repr (zbitfield_mask stop start)). - -Definition bitfield_maskl stop start := - Vlong(Int64.repr (zbitfield_mask stop start)). - -Definition insf stop start prev fld := - let mask := bitfield_mask stop start in - if is_bitfield stop start - then - Val.or (Val.and prev (Val.notint mask)) - (Val.and (Val.shl fld (Vint (Int.repr start))) mask) - else Vundef. - -Definition is_bitfieldl stop start := - (Z.leb start stop) - && (Z.geb start Z.zero) - && (Z.ltb stop Int64.zwordsize). - -Definition extfzl stop start v := - if is_bitfieldl stop start - then - let stop' := Z.add stop Z.one in - match v with - | Vlong w => - Vlong (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) - | _ => Vundef - end - else Vundef. - - -Definition extfsl stop start v := - if is_bitfieldl stop start - then - let stop' := Z.add stop Z.one in - match v with - | Vlong w => - Vlong (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) - | _ => Vundef - end - else Vundef. - -Definition insfl stop start prev fld := - let mask := bitfield_maskl stop start in - if is_bitfieldl stop start - then - Val.orl (Val.andl prev (Val.notl mask)) - (Val.andl (Val.shll fld (Vint (Int.repr start))) mask) - else Vundef. - -Fixpoint highest_bit (x : Z) (n : nat) : Z := - match n with - | O => 0 - | S n1 => - let n' := Z.of_N (N_of_nat n) in - if Z.testbit x n' - then n' - else highest_bit x n1 - end. - -Definition int_highest_bit (x : int) : Z := - highest_bit (Int.unsigned x) (31%nat). - - -Definition int64_highest_bit (x : int64) : Z := - highest_bit (Int64.unsigned x) (63%nat). - -Definition val_shrx (v1 v2: val): val := - match v1, v2 with - | Vint n1, Vint n2 => - if Int.ltu n2 (Int.repr 31) - then Vint(Int.shrx n1 n2) - else Vundef - | _, _ => Vundef - end. - -Definition val_shrxl (v1 v2: val): val := - match v1, v2 with - | Vlong n1, Vint n2 => - if Int.ltu n2 (Int.repr 63) - then Vlong(Int64.shrx' n1 n2) - else Vundef - | _, _ => Vundef - end. - -Remark modulus_fits_64: Int.modulus < Int64.max_unsigned. -Proof. - compute. - trivial. -Qed. - -Remark unsigned64_repr : - forall i, - -1 < i < Int.modulus -> - Int64.unsigned (Int64.repr i) = i. -Proof. - intros i H. - destruct H as [Hlow Hhigh]. - apply Int64.unsigned_repr. - split. { omega. } - pose proof modulus_fits_64. - omega. -Qed. - -Theorem divu_is_divlu: forall v1 v2 : val, - Val.divu v1 v2 = - match Val.divlu (Val.longofintu v1) (Val.longofintu v2) with - | None => None - | Some q => Some (Val.loword q) - end. -Proof. - intros. - destruct v1; simpl; trivial. - destruct v2; simpl; trivial. - destruct i as [i_val i_range]. - destruct i0 as [i0_val i0_range]. - simpl. - unfold Int.eq, Int64.eq, Int.zero, Int64.zero. - simpl. - rewrite Int.unsigned_repr by (compute; split; discriminate). - rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). - rewrite (unsigned64_repr i0_val) by assumption. - destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. - f_equal. f_equal. - unfold Int.divu, Int64.divu. simpl. - rewrite (unsigned64_repr i_val) by assumption. - rewrite (unsigned64_repr i0_val) by assumption. - unfold Int64.loword. - rewrite Int64.unsigned_repr. - reflexivity. - destruct (Z.eq_dec i0_val 1). - {subst i0_val. - pose proof modulus_fits_64. - rewrite Zdiv_1_r. - omega. - } - destruct (Z.eq_dec i_val 0). - { subst i_val. compute. - split; - intro ABSURD; - discriminate ABSURD. } - assert ((i_val / i0_val) < i_val). - { apply Z_div_lt; omega. } - split. - { apply Z_div_pos; omega. } - pose proof modulus_fits_64. - omega. -Qed. - -Theorem modu_is_modlu: forall v1 v2 : val, - Val.modu v1 v2 = - match Val.modlu (Val.longofintu v1) (Val.longofintu v2) with - | None => None - | Some q => Some (Val.loword q) - end. -Proof. - intros. - destruct v1; simpl; trivial. - destruct v2; simpl; trivial. - destruct i as [i_val i_range]. - destruct i0 as [i0_val i0_range]. - simpl. - unfold Int.eq, Int64.eq, Int.zero, Int64.zero. - simpl. - rewrite Int.unsigned_repr by (compute; split; discriminate). - rewrite (Int64.unsigned_repr 0) by (compute; split; discriminate). - rewrite (unsigned64_repr i0_val) by assumption. - destruct (zeq i0_val 0) as [ | Hnot0]; simpl; trivial. - f_equal. f_equal. - unfold Int.modu, Int64.modu. simpl. - rewrite (unsigned64_repr i_val) by assumption. - rewrite (unsigned64_repr i0_val) by assumption. - unfold Int64.loword. - rewrite Int64.unsigned_repr. - reflexivity. - assert((i_val mod i0_val) < i0_val). - apply Z_mod_lt. - omega. - split. - { apply Z_mod_lt. - omega. } - pose proof modulus_fits_64. - omega. -Qed. - -Remark if_zlt_0_half_modulus : - forall T : Type, - forall x y: T, - (if (zlt 0 Int.half_modulus) then x else y) = x. -Proof. - reflexivity. -Qed. - -Remark if_zlt_mone_half_modulus : - forall T : Type, - forall x y: T, - (if (zlt (Int.unsigned Int.mone) Int.half_modulus) then x else y) = y. -Proof. - reflexivity. -Qed. - -Remark if_zlt_min_signed_half_modulus : - forall T : Type, - forall x y: T, - (if (zlt (Int.unsigned (Int.repr Int.min_signed)) - Int.half_modulus) - then x - else y) = y. -Proof. - reflexivity. -Qed. - -Lemma repr_unsigned64_repr: - forall x, Int.repr (Int64.unsigned (Int64.repr x)) = Int.repr x. -Proof. - intros. - apply Int.eqm_samerepr. - unfold Int.eqm. - unfold Zbits.eqmod. - pose proof (Int64.eqm_unsigned_repr x) as H64. - unfold Int64.eqm in H64. - unfold Zbits.eqmod in H64. - destruct H64 as [k64 H64]. - change Int64.modulus with 18446744073709551616 in *. - change Int.modulus with 4294967296. - exists (-4294967296 * k64). - set (y := Int64.unsigned (Int64.repr x)) in *. - rewrite H64. - clear H64. - omega. -Qed. - -(* -Theorem divs_is_divls: forall v1 v2 : val, - match Val.divs v1 v2 with - | Some q => - match Val.divls (Val.longofint v1) (Val.longofint v2) with - | None => False - | Some q' => q = Val.loword q' - end - | None => True - end. -Proof. - intros. - destruct v1; simpl; trivial. - destruct v2; simpl; trivial. - destruct i as [i_val i_range]. - destruct i0 as [i0_val i0_range]. - simpl. - unfold Int.eq, Int64.eq, Int.zero, Int64.zero. - simpl. - replace (Int.unsigned (Int.repr 0)) with 0 in * by reflexivity. - destruct (zeq _ _) as [H0' | Hnot0]; simpl; trivial. - destruct (zeq i_val (Int.unsigned (Int.repr Int.min_signed))) as [Hmin | Hnotmin]; simpl. - { subst. - destruct (zeq i0_val (Int.unsigned Int.mone)) as [Hmone | Hnotmone]; trivial. - unfold Int.signed. simpl. - replace (Int64.unsigned (Int64.repr 0)) with 0 in * by reflexivity. - rewrite if_zlt_min_signed_half_modulus. - replace (if - zeq - (Int64.unsigned - (Int64.repr - (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) - (Int64.unsigned (Int64.repr Int64.min_signed)) - then true - else false) with false by reflexivity. - simpl. - rewrite orb_false_r. - destruct (zlt i0_val Int.half_modulus) as [Hlt_half | Hge_half]. - { - replace Int.half_modulus with 2147483648 in * by reflexivity. - rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; omega). - destruct (zeq _ _) as [ | Hneq0]; try omega. clear Hneq0. - unfold Val.loword. - f_equal. - unfold Int64.divs, Int.divs, Int64.loword. - unfold Int.signed, Int64.signed. simpl. - rewrite if_zlt_min_signed_half_modulus. - change Int.half_modulus with 2147483648 in *. - destruct (zlt _ _) as [discard|]; try omega. clear discard. - change (Int64.unsigned - (Int64.repr - (Int.unsigned (Int.repr Int.min_signed) - Int.modulus))) - with 18446744071562067968. - change Int64.half_modulus with 9223372036854775808. - change Int64.modulus with 18446744073709551616. - simpl. - rewrite (Int64.unsigned_repr i0_val) by (change Int64.max_unsigned with 18446744073709551615; omega). - destruct (zlt i0_val 9223372036854775808) as [discard |]; try omega. - clear discard. - change (Int.unsigned (Int.repr Int.min_signed) - Int.modulus) with (-2147483648). - destruct (Z.eq_dec i0_val 1) as [H1 | Hnot1]. - { subst. - rewrite Z.quot_1_r. - apply Int.eqm_samerepr. - unfold Int.eqm. - change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968. - unfold Zbits.eqmod. - change Int.modulus with 4294967296. - exists (-4294967296). - compute. - reflexivity. - } - change (-2147483648) with (-(2147483648)). - rewrite Z.quot_opp_l by assumption. - rewrite repr_unsigned64_repr. - reflexivity. - } - destruct (zeq _ _) as [Hmod|Hnmod]. - { - rewrite Int64.unsigned_repr_eq in Hmod. - set (delta := (i0_val - Int.modulus)) in *. - assert (delta = Int64.modulus*(delta/Int64.modulus)) as Hdelta. - { apply Z_div_exact_full_2. - compute. omega. - assumption. } - set (k := (delta / Int64.modulus)) in *. - change Int64.modulus with 18446744073709551616 in *. - change Int.modulus with 4294967296 in *. - change Int.half_modulus with 2147483648 in *. - change (Int.unsigned Int.mone) with 4294967295 in *. - omega. - } - unfold Int.divs, Int64.divs, Val.loword, Int64.loword. - change (Int.unsigned (Int.repr Int.min_signed)) with 2147483648. - change Int.modulus with 4294967296. - change (Int64.signed (Int64.repr (2147483648 - 4294967296))) with (-2147483648). - f_equal. - change (Int.signed {| Int.intval := 2147483648; Int.intrange := i_range |}) - with (-2147483648). - rewrite Int64.signed_repr. - { - replace (Int.signed {| Int.intval := i0_val; Int.intrange := i0_range |}) with (i0_val - 4294967296). - { rewrite repr_unsigned64_repr. - reflexivity. - } - *) - -Lemma big_unsigned_signed: - forall x, - (Int.unsigned x >= Int.half_modulus) -> - (Int.signed x) = (Int.unsigned x) - Int.modulus. -Proof. - destruct x as [xval xrange]. - intro BIG. - unfold Int.signed, Int.unsigned in *. simpl in *. - destruct (zlt _ _). - omega. - trivial. -Qed. - -(* -Lemma signed_0_eqb : - forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero. -Qed. - *) - -Lemma Z_quot_le: forall a b, - 0 <= a -> 1 <= b -> Z.quot a b <= a. -Proof. - intros a b Ha Hb. - destruct (Z.eq_dec b 1) as [Hb1 | Hb1]. - { (* b=1 *) - subst. - rewrite Z.quot_1_r. - auto with zarith. - } - destruct (Z.eq_dec a 0) as [Ha0 | Ha0]. - { (* a=0 *) - subst. - rewrite Z.quot_0_l. - auto with zarith. - omega. - } - assert ((Z.quot a b) < a). - { - apply Z.quot_lt; omega. - } - auto with zarith. -Qed. - -(* -Lemma divs_is_quot: forall v1 v2 : val, - Val.divs v1 v2 = - match v1, v2 with - | (Vint w1), (Vint w2) => - let q := Z.quot (Int.signed w1) (Int.signed w2) in - if (negb (Z.eqb (Int.signed w2) 0)) - && (Z.geb q Int.min_signed) && (Z.leb q Int.max_signed) - then Some (Vint (Int.repr q)) - else None - | _, _ => None - end. - -Proof. - destruct v1; destruct v2; simpl; trivial. - unfold Int.divs. - rewrite signed_0_eqb. - destruct (Int.eq i0 Int.zero) eqn:Eeq0; simpl; trivial. - destruct (Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone) eqn:EXCEPTION. - { replace (Int.signed i0) with (-1). - replace (Int.signed i) with Int.min_signed. - change Int.min_signed with (-2147483648). - change Int.max_signed with (2147483647). - compute. - reflexivity. - { unfold Int.eq in EXCEPTION. - destruct (zeq _ _) as [Hmin | ] in EXCEPTION; try discriminate. - change Int.min_signed with (-2147483648). - change (Int.unsigned (Int.repr Int.min_signed)) with (2147483648) in *. - rewrite big_unsigned_signed. - change Int.modulus with 4294967296. - omega. - change Int.half_modulus with 2147483648. - omega. - } - unfold Int.eq in EXCEPTION. - destruct (zeq _ _) in EXCEPTION; try discriminate. - destruct (zeq _ _) as [Hmone | ] in EXCEPTION; try discriminate. - destruct i0 as [i0val i0range]; unfold Int.signed in *; simpl in *. - rewrite Hmone. - reflexivity. - } - replace (Int.signed i ÷ Int.signed i0 >=? Int.min_signed) with true. - replace (Int.signed i ÷ Int.signed i0 <=? Int.max_signed) with true. - reflexivity. - { assert (Int.signed i ÷ Int.signed i0 <= Int.max_signed). - { - destruct (Z_lt_le_dec (Int.signed i) 0). - { - apply Z.le_trans with (m:=0). - rewrite <- (Z.quot_0_l (Int.signed i0)). - Require Import Coq.ZArith.Zquot. - apply Z_quot_monotone. - } - assert ( Int.signed i ÷ Int.signed i0 <= Int.signed i). - apply Z_quot_le. - } - } - - *) - -Require Import Coq.ZArith.Zquot. -Lemma Z_quot_pos_pos_bound: forall a b m, - 0 <= a <= m -> 1 <= b -> 0 <= Z.quot a b <= m. -Proof. - intros. - split. - { rewrite <- (Z.quot_0_l b) by omega. - apply Z_quot_monotone; omega. - } - apply Z.le_trans with (m := a). - { - apply Z_quot_le; tauto. - } - tauto. -Qed. -Lemma Z_quot_neg_pos_bound: forall a b m, - m <= a <= 0 -> 1 <= b -> m <= Z.quot a b <= 0. - intros. - assert (0 <= - (a ÷ b) <= -m). - { - rewrite <- Z.quot_opp_l by omega. - apply Z_quot_pos_pos_bound; omega. - } - omega. -Qed. - -Lemma Z_quot_signed_pos_bound: forall a b, - Int.min_signed <= a <= Int.max_signed -> 1 <= b -> - Int.min_signed <= Z.quot a b <= Int.max_signed. -Proof. - intros. - destruct (Z_lt_ge_dec a 0). - { - split. - { apply Z_quot_neg_pos_bound; omega. } - { eapply Z.le_trans with (m := 0). - { apply Z_quot_neg_pos_bound with (m := Int.min_signed); trivial. - split. tauto. auto with zarith. - } - discriminate. - } - } - { split. - { eapply Z.le_trans with (m := 0). - discriminate. - apply Z_quot_pos_pos_bound with (m := Int.max_signed); trivial. - split. omega. tauto. - } - { apply Z_quot_pos_pos_bound; omega. - } - } -Qed. - -Lemma Z_quot_signed_neg_bound: forall a b, - Int.min_signed <= a <= Int.max_signed -> b < -1 -> - Int.min_signed <= Z.quot a b <= Int.max_signed. -Proof. - change Int.min_signed with (-2147483648). - change Int.max_signed with 2147483647. - intros. - - replace b with (-(-b)) by auto with zarith. - rewrite Z.quot_opp_r by omega. - assert (-2147483647 <= (a ÷ - b) <= 2147483648). - 2: omega. - - destruct (Z_lt_ge_dec a 0). - { - replace a with (-(-a)) by auto with zarith. - rewrite Z.quot_opp_l by omega. - assert (-2147483648 <= - a ÷ - b <= 2147483647). - 2: omega. - split. - { - rewrite Z.quot_opp_l by omega. - assert (a ÷ - b <= 2147483648). - 2: omega. - { - apply Z.le_trans with (m := 0). - rewrite <- (Z.quot_0_l (-b)) by omega. - apply Z_quot_monotone; omega. - discriminate. - } - } - assert (- a ÷ - b < -a ). - 2: omega. - apply Z_quot_lt; omega. - } - { - split. - { apply Z.le_trans with (m := 0). - discriminate. - rewrite <- (Z.quot_0_l (-b)) by omega. - apply Z_quot_monotone; omega. - } - { apply Z.le_trans with (m := a). - apply Z_quot_le. - all: omega. - } - } -Qed. - -Lemma sub_add_neg : - forall x y, Val.sub x y = Val.add x (Val.neg y). -Proof. - destruct x; destruct y; simpl; trivial. - f_equal. - apply Int.sub_add_opp. -Qed. - -Lemma neg_mul_distr_r : - forall x y, Val.neg (Val.mul x y) = Val.mul x (Val.neg y). -Proof. - destruct x; destruct y; simpl; trivial. - f_equal. - apply Int.neg_mul_distr_r. -Qed. - -(* pointer diff -Lemma sub_addl_negl : - forall x y, Val.subl x y = Val.addl x (Val.negl y). -Proof. - destruct x; destruct y; simpl; trivial. - + f_equal. apply Int64.sub_add_opp. - + destruct (Archi.ptr64) eqn:ARCHI64; trivial. - f_equal. rewrite Ptrofs.sub_add_opp. - pose (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 i0) i0) as Hagree. - unfold Ptrofs.agree64 in Hagree. - unfold Ptrofs.add. - f_equal. f_equal. - rewrite Hagree. - pose (Ptrofs.agree64_of_int ARCHI64 (Int64.neg i0)) as Hagree2. - rewrite Hagree2. - reflexivity. - exact (Ptrofs.agree64_of_int ARCHI64 i0). - + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. - destruct (eq_block _ _); simpl; trivial. -Qed. - *) - -Lemma negl_mull_distr_r : - forall x y, Val.negl (Val.mull x y) = Val.mull x (Val.negl y). -Proof. - destruct x; destruct y; simpl; trivial. - f_equal. - apply Int64.neg_mul_distr_r. -Qed. - -Definition addx sh v1 v2 := - Val.add v2 (Val.shl v1 (Vint sh)). - -Definition addxl sh v1 v2 := - Val.addl v2 (Val.shll v1 (Vint sh)). - -Definition revsubx sh v1 v2 := - Val.sub v2 (Val.shl v1 (Vint sh)). - -Definition revsubxl sh v1 v2 := - Val.subl v2 (Val.shll v1 (Vint sh)). - -Definition minf v1 v2 := - match v1, v2 with - | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.min f1 f2) - | _, _ => Vundef - end. - -Definition maxf v1 v2 := - match v1, v2 with - | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.max f1 f2) - | _, _ => Vundef - end. - -Definition minfs v1 v2 := - match v1, v2 with - | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.min f1 f2) - | _, _ => Vundef - end. - -Definition maxfs v1 v2 := - match v1, v2 with - | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2) - | _, _ => Vundef - end. - -Definition invfs v1 := - match v1 with - | (Vsingle f1) => Vsingle (ExtFloat32.inv f1) - | _ => Vundef - end. - -Definition triple_op_float f v1 v2 v3 := - match v1, v2, v3 with - | (Vfloat f1), (Vfloat f2), (Vfloat f3) => Vfloat (f f1 f2 f3) - | _, _, _ => Vundef - end. - -Definition triple_op_single f v1 v2 v3 := - match v1, v2, v3 with - | (Vsingle f1), (Vsingle f2), (Vsingle f3) => Vsingle (f f1 f2 f3) - | _, _, _ => Vundef - end. - -Definition fmaddf := triple_op_float (fun f1 f2 f3 => Float.fma f2 f3 f1). -Definition fmaddfs := triple_op_single (fun f1 f2 f3 => Float32.fma f2 f3 f1). - -Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma (Float.neg f2) f3 f1). -Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma (Float32.neg f2) f3 f1). diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml deleted file mode 100644 index e4dc3f97..00000000 --- a/mppa_k1c/InstructionScheduler.ml +++ /dev/null @@ -1,1247 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Schedule instructions on a synchronized pipeline -@author David Monniaux, CNRS, VERIMAG *) - -type latency_constraint = { - instr_from : int; - instr_to : int; - latency : int };; - -type problem = { - max_latency : int; - resource_bounds : int array; - instruction_usages : int array array; - latency_constraints : latency_constraint list; - };; - -let print_problem channel problem = - (if problem.max_latency >= 0 - then Printf.fprintf channel "max makespan: %d\n" problem.max_latency); - output_string channel "resource bounds:"; - (Array.iter (fun b -> Printf.fprintf channel " %d" b) problem.resource_bounds); - output_string channel ";\n"; - (Array.iteri (fun i v -> - Printf.fprintf channel "instr%d:" i; - (Array.iter (fun b -> Printf.fprintf channel " %d" b) v); - output_string channel ";\n") problem.instruction_usages); - List.iter (fun instr -> - Printf.printf "t%d - t%d >= %d;\n" - instr.instr_to instr.instr_from instr.latency) - problem.latency_constraints;; - -let get_nr_instructions problem = Array.length problem.instruction_usages;; -let get_nr_resources problem = Array.length problem.resource_bounds;; - -type solution = int array -type scheduler = problem -> solution option - -(* DISABLED -(** Schedule the problem optimally by constraint solving using the Gecode solver. *) -external gecode_scheduler : problem -> solution option = - "caml_gecode_schedule_instr";; - *) - -let maximum_slot_used times = - let maxi = ref (-1) in - for i=0 to (Array.length times)-2 - do - maxi := max !maxi times.(i) - done; - !maxi;; - -let check_schedule (problem : problem) (times : solution) = - let nr_instructions = get_nr_instructions problem in - (if Array.length times <> nr_instructions+1 - then failwith - (Printf.sprintf "check_schedule: %d times expected, got %d" - (nr_instructions+1) (Array.length times))); - (if problem.max_latency >= 0 && times.(nr_instructions)> problem.max_latency - then failwith "check_schedule: max_latency exceeded"); - (Array.iteri (fun i time -> - (if time < 0 - then failwith (Printf.sprintf "time[%d] < 0" i))) times); - let slot_resources = Array.init ((maximum_slot_used times)+1) - (fun _ -> Array.copy problem.resource_bounds) in - for i=0 to nr_instructions -1 - do - let remaining_resources = slot_resources.(times.(i)) - and used_resources = problem.instruction_usages.(i) in - for resource=0 to (Array.length used_resources)-1 - do - let after = remaining_resources.(resource) - used_resources.(resource) in - (if after < 0 - then failwith (Printf.sprintf "check_schedule: instruction %d exceeds resource %d at slot %d" i resource times.(i))); - remaining_resources.(resource) <- after - done - done; - List.iter (fun ctr -> - if times.(ctr.instr_to) - times.(ctr.instr_from) < ctr.latency - then failwith (Printf.sprintf "check_schedule: time[%d]=%d - time[%d]=%d < %d" - ctr.instr_to times.(ctr.instr_to) - ctr.instr_from times.(ctr.instr_from) - ctr.latency) - ) problem.latency_constraints;; - -let bound_max_time problem = - let total = ref(Array.length problem.instruction_usages) in - List.iter (fun ctr -> total := !total + ctr.latency) problem.latency_constraints; - !total;; - -let vector_less_equal a b = - try - Array.iter2 (fun x y -> - if x>y - then raise Exit) a b; - true - with Exit -> false;; - -let vector_subtract a b = - assert ((Array.length a) = (Array.length b)); - for i=0 to (Array.length a)-1 - do - b.(i) <- b.(i) - a.(i) - done;; - -(* The version with critical path ordering is much better! *) -type list_scheduler_order = - | INSTRUCTION_ORDER - | CRITICAL_PATH_ORDER;; - -let int_max (x : int) (y : int) = - if x > y then x else y;; - -let int_min (x : int) (y : int) = - if x < y then x else y;; - -let get_predecessors problem = - let nr_instructions = get_nr_instructions problem in - let predecessors = Array.make (nr_instructions+1) [] in - List.iter (fun ctr -> - predecessors.(ctr.instr_to) <- - (ctr.instr_from, ctr.latency)::predecessors.(ctr.instr_to)) - problem.latency_constraints; - predecessors;; - -let get_successors problem = - let nr_instructions = get_nr_instructions problem in - let successors = Array.make nr_instructions [] in - List.iter (fun ctr -> - successors.(ctr.instr_from) <- - (ctr.instr_to, ctr.latency)::successors.(ctr.instr_from)) - problem.latency_constraints; - successors;; - -let critical_paths successors = - let nr_instructions = Array.length successors in - let path_lengths = Array.make nr_instructions (-1) in - let rec compute i = - if i=nr_instructions then 0 else - match path_lengths.(i) with - | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" - | -1 -> path_lengths.(i) <- -2; - let x = List.fold_left - (fun cur (j, latency)-> int_max cur (latency+(compute j))) - 1 successors.(i) - in path_lengths.(i) <- x; x - | x -> x - in for i = nr_instructions-1 downto 0 - do - ignore (compute i) - done; - path_lengths;; - -let maximum_critical_path problem = - let paths = critical_paths (get_successors problem) in - Array.fold_left int_max 0 paths;; - -let get_earliest_dates predecessors = - let nr_instructions = (Array.length predecessors)-1 in - let path_lengths = Array.make (nr_instructions+1) (-1) in - let rec compute i = - match path_lengths.(i) with - | -2 -> failwith "InstructionScheduler: the dependency graph has cycles" - | -1 -> path_lengths.(i) <- -2; - let x = List.fold_left - (fun cur (j, latency)-> int_max cur (latency+(compute j))) - 0 predecessors.(i) - in path_lengths.(i) <- x; x - | x -> x - in for i = 0 to nr_instructions - do - ignore (compute i) - done; - for i = 0 to nr_instructions - 1 - do - path_lengths.(nr_instructions) <- int_max - path_lengths.(nr_instructions) (1 + path_lengths.(i)) - done; - path_lengths;; - -exception Unschedulable - -let get_latest_dates deadline successors = - let nr_instructions = Array.length successors - and path_lengths = critical_paths successors in - Array.init (nr_instructions + 1) - (fun i -> - if i < nr_instructions then - let path_length = path_lengths.(i) in - assert (path_length >= 1); - (if path_length > deadline - then raise Unschedulable); - deadline - path_length - else deadline);; - -let priority_list_scheduler (order : list_scheduler_order) - (problem : problem) : - solution option = - let nr_instructions = get_nr_instructions problem in - let successors = get_successors problem - and predecessors = get_predecessors problem - and times = Array.make (nr_instructions+1) (-1) in - - let priorities = match order with - | INSTRUCTION_ORDER -> None - | CRITICAL_PATH_ORDER -> Some (critical_paths successors) in - - let module InstrSet = - Set.Make (struct type t=int - let compare = match priorities with - | None -> (fun x y -> x - y) - | Some p -> (fun x y -> - (match p.(y)-p.(x) with - | 0 -> x - y - | z -> z)) - end) in - - let max_time = bound_max_time problem in - let ready = Array.make max_time InstrSet.empty in - Array.iteri (fun i preds -> - if i - if times.(j) < 0 - then raise Exit - else let t = times.(j) + latency in - if t > !time - then time := t) predecessors.(i); - assert(!time >= 0); - !time - with Exit -> -1 - - in - let advance_time() = - begin - (if !current_time < max_time-1 - then - begin - Array.blit problem.resource_bounds 0 current_resources 0 - (Array.length current_resources); - ready.(!current_time + 1) <- - InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1)); - ready.(!current_time) <- InstrSet.empty; - end); - incr current_time - end in - - let attempt_scheduling ready usages = - let result = ref (-1) in - try - InstrSet.iter (fun i -> - (* Printf.printf "trying scheduling %d\n" i; - pr int_vector usages.(i); - print _vector current_resources; *) - if vector_less_equal usages.(i) current_resources - then - begin - vector_subtract usages.(i) current_resources; - result := i; - raise Exit - end) ready; - -1 - with Exit -> !result in - - while !current_time < max_time - do - if (InstrSet.is_empty ready.(!current_time)) - then advance_time() - else - match attempt_scheduling ready.(!current_time) - problem.instruction_usages with - | -1 -> advance_time() - | i -> - begin - assert(times.(i) < 0); - times.(i) <- !current_time; - ready.(!current_time) <- InstrSet.remove i (ready.(!current_time)); - List.iter (fun (instr_to, latency) -> - if instr_to < nr_instructions then - match earliest_time instr_to with - | -1 -> () - | to_time -> - ready.(to_time) <- InstrSet.add instr_to ready.(to_time)) - successors.(i); - successors.(i) <- [] - end - done; - try - let final_time = ref (-1) in - for i=0 to nr_instructions-1 - do - (if times.(i) < 0 then raise Exit); - (if !final_time < times.(i)+1 then final_time := times.(i)+1) - done; - List.iter (fun (i, latency) -> - let target_time = latency + times.(i) in - if target_time > !final_time - then final_time := target_time - ) predecessors.(nr_instructions); - times.(nr_instructions) <- !final_time; - Some times - with Exit -> None;; - -let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;; - -(* dummy code for placating ocaml's warnings *) -let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;; - -type bundle = int list;; - -let rec extract_deps_to index = function - | [] -> [] - | dep :: deps -> let extracts = extract_deps_to index deps in - if (dep.instr_to == index) then - dep :: extracts - else - extracts - -exception InvalidBundle;; - -let dependency_check problem bundle index = - let index_deps = extract_deps_to index problem.latency_constraints in - List.iter (fun i -> - List.iter (fun dep -> - if (dep.instr_from == i) then raise InvalidBundle - ) index_deps - ) bundle;; - -let rec make_bundle problem resources bundle index = - let resources_copy = Array.copy resources in - let nr_instructions = get_nr_instructions problem in - if (index >= nr_instructions) then (bundle, index+1) else - let inst_usage = problem.instruction_usages.(index) in - try match vector_less_equal inst_usage resources with - | false -> raise InvalidBundle - | true -> ( - dependency_check problem bundle index; - vector_subtract problem.instruction_usages.(index) resources_copy; - make_bundle problem resources_copy (index::bundle) (index+1) - ) - with InvalidBundle -> (bundle, index);; - -let rec make_bundles problem index : bundle list = - if index >= get_nr_instructions problem then - [] - else - let (bundle, new_index) = make_bundle problem problem.resource_bounds [] index in - bundle :: (make_bundles problem new_index);; - -let bundles_to_schedule problem bundles : solution = - let nr_instructions = get_nr_instructions problem in - let schedule = Array.make (nr_instructions+1) (nr_instructions+4) in - let time = ref 0 in - List.iter (fun bundle -> - begin - List.iter (fun i -> - schedule.(i) <- !time - ) bundle; - time := !time + 1 - end - ) bundles; schedule;; - -let greedy_scheduler (problem : problem) : solution option = - let bundles = make_bundles problem 0 in - Some (bundles_to_schedule problem bundles);; - -(* alternate implementation -let swap_array_elements a i j = - let x = a.(i) in - a.(i) <- a.(j); - a.(j) <- x;; - -let array_reverse_slice a first last = - let i = ref first and j = ref last in - while i < j - do - swap_array_elements a !i !j; - incr i; - decr j - done;; - -let array_reverse a = - let a' = Array.copy a in - array_reverse_slice a' 0 ((Array.length a)-1); - a';; - *) - -(* unneeded -let array_reverse a = - let n=Array.length a in - Array.init n (fun i -> a.(n-1-i));; - *) - -let reverse_constraint nr_instructions ctr = - { instr_to = nr_instructions -ctr.instr_from; - instr_from = nr_instructions - ctr.instr_to; - latency = ctr.latency };; - -(* unneeded -let rec list_map_filter f = function - | [] -> [] - | h::t -> - (match f h with - | None -> list_map_filter f t - | Some x -> x :: (list_map_filter f t));; - *) - -let reverse_problem problem = - let nr_instructions = get_nr_instructions problem in - { - max_latency = problem.max_latency; - resource_bounds = problem.resource_bounds; - instruction_usages = Array.init (nr_instructions + 1) - (fun i -> - if i=0 - then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i)); - latency_constraints = List.map (reverse_constraint nr_instructions) - problem.latency_constraints - };; - -let max_scheduled_time solution = - let time = ref (-1) in - for i = 0 to ((Array.length solution) - 2) - do - time := max !time solution.(i) - done; - !time;; - -(* -let recompute_makespan problem solution = - let n = (Array.length solution) - 1 and ms = ref 0 in - List.iter (fun cstr -> - if cstr.instr_to = n - then ms := max !ms (solution.(cstr.instr_from) + cstr.latency) - ) problem.latency_constraints; - !ms;; - *) - -let schedule_reversed (scheduler : problem -> solution option) - (problem : problem) = - match scheduler (reverse_problem problem) with - | None -> None - | Some solution -> - let nr_instructions = get_nr_instructions problem in - let makespan = max_scheduled_time solution in - let ret = Array.init (nr_instructions + 1) - (fun i -> makespan-solution.(nr_instructions-i)) in - ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1) - (ret.(nr_instructions)); - Some ret;; - -(** Schedule the problem using a greedy list scheduling algorithm, from the end. *) -let reverse_list_scheduler = schedule_reversed list_scheduler;; - -let check_problem problem = - (if (Array.length problem.instruction_usages) < 1 - then failwith "length(problem.instruction_usages) < 1");; - -let validated_scheduler (scheduler : problem -> solution option) - (problem : problem) = - check_problem problem; - match scheduler problem with - | None -> None - | (Some solution) as ret -> check_schedule problem solution; ret;; - -let get_max_latency solution = - solution.((Array.length solution)-1);; - -let show_date_ranges problem = - let deadline = problem.max_latency in - assert(deadline >= 0); - let successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates : int array = get_earliest_dates predecessors - and latest_dates : int array = get_latest_dates deadline successors in - assert ((Array.length earliest_dates) = - (Array.length latest_dates)); - Array.iteri (fun i early -> - let late = latest_dates.(i) in - Printf.printf "t[%d] in %d..%d\n" i early late) - earliest_dates;; - -type pseudo_boolean_problem_type = - | SATISFIABILITY - | OPTIMIZATION;; - -type pseudo_boolean_mapper = { - mapper_pb_type : pseudo_boolean_problem_type; - mapper_nr_instructions : int; - mapper_nr_pb_variables : int; - mapper_earliest_dates : int array; - mapper_latest_dates : int array; - mapper_var_offsets : int array; - mapper_final_predecessors : (int * int) list -};; - -(* Latency constraints are: - presence of instr-to at each t <= sum of presences of instr-from at compatible times - - if reverse_encoding - presence of instr-from at each t <= sum of presences of instr-to at compatible times *) - -(* Experiments show reverse_encoding=true multiplies time by 2 in sat4j - without making hard instances easier *) -let direct_encoding = false -and reverse_encoding = false -and delta_encoding = true - -let pseudo_boolean_print_problem channel problem pb_type = - let deadline = problem.max_latency in - assert (deadline > 0); - let nr_instructions = get_nr_instructions problem - and nr_resources = get_nr_resources problem - and successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates = get_earliest_dates predecessors - and latest_dates = get_latest_dates deadline successors in - let var_offsets = Array.make - (match pb_type with - | OPTIMIZATION -> nr_instructions+1 - | SATISFIABILITY -> nr_instructions) 0 in - let nr_pb_variables = - (let nr = ref 0 in - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - var_offsets.(i) <- !nr; - nr := !nr + latest_dates.(i) - earliest_dates.(i) + 1 - done; - !nr) - and nr_pb_constraints = - (match pb_type with - | OPTIMIZATION -> nr_instructions+1 - | SATISFIABILITY -> nr_instructions) + - - (let count = ref 0 in - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - try - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 then raise Exit - done - with Exit -> incr count - done - done; - !count) + - - (let count=ref 0 in - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions - then count := !count + 1 + latest_dates.(ctr.instr_to) - - earliest_dates.(ctr.instr_to) - + (if reverse_encoding - then 1 + latest_dates.(ctr.instr_from) - - earliest_dates.(ctr.instr_from) - else 0) - ) - problem.latency_constraints; - !count) + - - (match pb_type with - | OPTIMIZATION -> (1 + deadline - earliest_dates.(nr_instructions)) * nr_instructions - | SATISFIABILITY -> 0) - and measured_nr_constraints = ref 0 in - - let pb_var i t = - assert(t >= earliest_dates.(i)); - assert(t <= latest_dates.(i)); - let v = 1+var_offsets.(i)+t-earliest_dates.(i) in - assert(v <= nr_pb_variables); - Printf.sprintf "x%d" v in - - let end_constraint () = - begin - output_string channel ";\n"; - incr measured_nr_constraints - end in - - let gen_latency_constraint i_to i_from latency t_to = - Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_to; - for t_from=earliest_dates.(i_from) to - int_min latest_dates.(i_from) (t_to - latency) - do - Printf.fprintf channel "+1 %s " (pb_var i_from t_from) - done; - Printf.fprintf channel "-1 %s " (pb_var i_to t_to); - Printf.fprintf channel ">= 0"; - end_constraint() - - and gen_dual_latency_constraint i_to i_from latency t_from = - Printf.fprintf channel "* t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_from; - for t_to=int_max earliest_dates.(i_to) (t_from + latency) - to latest_dates.(i_to) - do - Printf.fprintf channel "+1 %s " (pb_var i_to t_to) - done; - Printf.fprintf channel "-1 %s " (pb_var i_from t_from); - Printf.fprintf channel ">= 0"; - end_constraint() - in - - Printf.fprintf channel "* #variable= %d #constraint= %d\n" nr_pb_variables nr_pb_constraints; - Printf.fprintf channel "* nr_instructions=%d deadline=%d\n" nr_instructions deadline; - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - output_string channel "min:"; - for t=earliest_dates.(nr_instructions) to deadline - do - Printf.fprintf channel " %+d %s" t (pb_var nr_instructions t) - done; - output_string channel ";\n"; - end; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - Printf.fprintf channel "* t[%d] in %d..%d\n" i early late; - for t=early to late - do - Printf.fprintf channel "+1 %s " (pb_var i t) - done; - Printf.fprintf channel "= 1"; - end_constraint() - done; - - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - let bound = problem.resource_bounds.(j) - and coeffs = ref [] in - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 - then coeffs := (i, usage) :: !coeffs - done; - if !coeffs <> [] then - begin - Printf.fprintf channel "* resource #%d at t=%d <= %d\n" j t bound; - List.iter (fun (i, usage) -> - Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; - Printf.fprintf channel ">= %d" (-bound); - end_constraint(); - end - done - done; - - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions then - begin - for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) - do - gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to - done; - if reverse_encoding - then - for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) - do - gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from - done - end - ) problem.latency_constraints; - - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - let final_latencies = Array.make nr_instructions 1 in - List.iter (fun (i, latency) -> - final_latencies.(i) <- int_max final_latencies.(i) latency) - predecessors.(nr_instructions); - for t_to=earliest_dates.(nr_instructions) to deadline - do - for i_from = 0 to nr_instructions -1 - do - gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to - done - done - end; - assert (!measured_nr_constraints = nr_pb_constraints); - { - mapper_pb_type = pb_type; - mapper_nr_instructions = nr_instructions; - mapper_nr_pb_variables = nr_pb_variables; - mapper_earliest_dates = earliest_dates; - mapper_latest_dates = latest_dates; - mapper_var_offsets = var_offsets; - mapper_final_predecessors = predecessors.(nr_instructions) - };; - -type pb_answer = - | Positive - | Negative - | Unknown - -let line_to_pb_solution sol line nr_pb_variables = - let assign s v = - begin - let i = int_of_string s in - sol.(i-1) <- v - end in - List.iter - begin - function "" -> () - | item -> - (match String.get item 0 with - | '+' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Positive - | '-' -> - assert ((String.length item) >= 3); - assert ((String.get item 1) = 'x'); - assign (String.sub item 2 ((String.length item)-2)) Negative - | 'x' -> - assert ((String.length item) >= 2); - assign (String.sub item 1 ((String.length item)-1)) Positive - | _ -> failwith "syntax error in pseudo Boolean solution: epected + - or x" - ) - end - (String.split_on_char ' ' (String.sub line 2 ((String.length line)-2)));; - -let pb_solution_to_schedule mapper pb_solution = - Array.mapi (fun i offset -> - let first = mapper.mapper_earliest_dates.(i) - and last = mapper.mapper_latest_dates.(i) - and time = ref (-1) in - for t=first to last - do - match pb_solution.(t - first + offset) with - | Positive -> - (if !time = -1 - then time:=t - else failwith "duplicate time in pseudo boolean solution") - | Negative -> () - | Unknown -> failwith "unknown value in pseudo boolean solution" - done; - (if !time = -1 - then failwith "no time in pseudo boolean solution"); - !time - ) mapper.mapper_var_offsets;; - -let pseudo_boolean_read_solution mapper channel = - let optimum = ref (-1) - and optimum_found = ref false - and solution = Array.make mapper.mapper_nr_pb_variables Unknown in - try - while true do - match input_line channel with - | "" -> () - | line -> - begin - match String.get line 0 with - | 'c' -> () - | 'o' -> - assert ((String.length line) >= 2); - assert ((String.get line 1) = ' '); - optimum := int_of_string (String.sub line 2 ((String.length line)-2)) - | 's' -> (match line with - | "s OPTIMUM FOUND" -> optimum_found := true - | "s SATISFIABLE" -> () - | "s UNSATISFIABLE" -> close_in channel; - raise Unschedulable - | _ -> failwith line) - | 'v' -> line_to_pb_solution solution line mapper.mapper_nr_pb_variables - | x -> Printf.printf "unknown: %s\n" line - end - done; - assert false - with End_of_file -> - close_in channel; - begin - let sol = pb_solution_to_schedule mapper solution in - sol - end;; - -let recompute_max_latency mapper solution = - let maxi = ref (-1) in - for i=0 to (mapper.mapper_nr_instructions-1) - do - maxi := int_max !maxi (1+solution.(i)) - done; - List.iter (fun (i, latency) -> - maxi := int_max !maxi (solution.(i) + latency)) mapper.mapper_final_predecessors; - !maxi;; - -let adjust_check_solution mapper solution = - match mapper.mapper_pb_type with - | OPTIMIZATION -> - let max_latency = recompute_max_latency mapper solution in - assert (max_latency = solution.(mapper.mapper_nr_instructions)); - solution - | SATISFIABILITY -> - let max_latency = recompute_max_latency mapper solution in - Array.init (mapper.mapper_nr_instructions+1) - (fun i -> if i < mapper.mapper_nr_instructions - then solution.(i) - else max_latency);; - -(* let pseudo_boolean_solver = ref "/local/monniaux/progs/naps/naps" *) -(* let pseudo_boolean_solver = ref "/local/monniaux/packages/sat4j/org.sat4j.pb.jar CuttingPlanes" *) - -(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar CuttingPlanes" *) -(* let pseudo_boolean_solver = ref "java -jar /usr/share/java/org.sat4j.pb.jar" *) -(* let pseudo_boolean_solver = ref "clasp" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/open-wbo/open-wbo_static -formula=1" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/naps/naps" *) -(* let pseudo_boolean_solver = ref "/home/monniaux/progs/CP/minisatp/build/release/bin/minisatp" *) -(* let pseudo_boolean_solver = ref "java -jar sat4j-pb.jar CuttingPlanesStar" *) -let pseudo_boolean_solver = ref "pb_solver" - -let pseudo_boolean_scheduler pb_type problem = - try - let filename_in = "problem.opb" - (* needed only if not using stdout and filename_out = "problem.sol" *) in - let opb_problem = open_out filename_in in - let mapper = pseudo_boolean_print_problem opb_problem problem pb_type in - close_out opb_problem; - - let opb_solution = Unix.open_process_in (!pseudo_boolean_solver ^ " " ^ filename_in) in - let ret = adjust_check_solution mapper (pseudo_boolean_read_solution mapper opb_solution) in - close_in opb_solution; - Some ret - with - | Unschedulable -> None;; - -let rec reoptimizing_scheduler (scheduler : scheduler) (previous_solution : solution) (problem : problem) = - if (get_max_latency previous_solution)>1 then - begin - Printf.printf "reoptimizing < %d\n" (get_max_latency previous_solution); - flush stdout; - match scheduler - { problem with max_latency = (get_max_latency previous_solution)-1 } - with - | None -> previous_solution - | Some solution -> reoptimizing_scheduler scheduler solution problem - end - else previous_solution;; - -let smt_var i = Printf.sprintf "t%d" i - -let is_resource_used problem j = - try - Array.iter (fun usages -> - if usages.(j) > 0 - then raise Exit) problem.instruction_usages; - false - with Exit -> true;; - -let smt_use_quantifiers = false - -let smt_print_problem channel problem = - let nr_instructions = get_nr_instructions problem in - let gen_smt_resource_constraint time j = - output_string channel "(<= (+"; - Array.iteri - (fun i usages -> - let usage=usages.(j) in - if usage > 0 - then Printf.fprintf channel " (ite (= %s %s) %d 0)" - time (smt_var i) usage) - problem.instruction_usages; - Printf.fprintf channel ") %d)" problem.resource_bounds.(j) - in - output_string channel "(set-option :produce-models true)\n"; - for i=0 to nr_instructions - do - Printf.fprintf channel "(declare-const %s Int)\n" (smt_var i); - Printf.fprintf channel "(assert (>= %s 0))\n" (smt_var i) - done; - for i=0 to nr_instructions-1 - do - Printf.fprintf channel "(assert (< %s %s))\n" - (smt_var i) (smt_var nr_instructions) - done; - (if problem.max_latency > 0 - then Printf.fprintf channel "(assert (<= %s %d))\n" - (smt_var nr_instructions) problem.max_latency); - List.iter (fun ctr -> - Printf.fprintf channel "(assert (>= (- %s %s) %d))\n" - (smt_var ctr.instr_to) - (smt_var ctr.instr_from) - ctr.latency) problem.latency_constraints; - for j=0 to (Array.length problem.resource_bounds)-1 - do - if is_resource_used problem j - then - begin - if smt_use_quantifiers - then - begin - Printf.fprintf channel - "; resource #%d <= %d\n(assert (forall ((t Int)) " - j problem.resource_bounds.(j); - gen_smt_resource_constraint "t" j; - output_string channel "))\n" - end - else - begin - (if problem.max_latency < 0 - then failwith "quantifier explosion needs max latency"); - for t=0 to problem.max_latency - do - Printf.fprintf channel - "; resource #%d <= %d at t=%d\n(assert " - j problem.resource_bounds.(j) t; - gen_smt_resource_constraint (string_of_int t) j; - output_string channel ")\n" - done - end - end - done; - output_string channel "(check-sat)(get-model)\n";; - - -let ilp_print_problem channel problem pb_type = - let deadline = problem.max_latency in - assert (deadline > 0); - let nr_instructions = get_nr_instructions problem - and nr_resources = get_nr_resources problem - and successors = get_successors problem - and predecessors = get_predecessors problem in - let earliest_dates = get_earliest_dates predecessors - and latest_dates = get_latest_dates deadline successors in - - let pb_var i t = - Printf.sprintf "x%d_%d" i t in - - let gen_latency_constraint i_to i_from latency t_to = - Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_to; - Printf.fprintf channel "c_%d_%d_%d_%d: " - i_to i_from latency t_to; - for t_from=earliest_dates.(i_from) to - int_min latest_dates.(i_from) (t_to - latency) - do - Printf.fprintf channel "+1 %s " (pb_var i_from t_from) - done; - Printf.fprintf channel "-1 %s " (pb_var i_to t_to); - output_string channel ">= 0\n" - - and gen_dual_latency_constraint i_to i_from latency t_from = - Printf.fprintf channel "\\ t[%d] - t[%d] >= %d when t[%d]=%d\n" - i_to i_from latency i_to t_from; - Printf.fprintf channel "d_%d_%d_%d_%d: " - i_to i_from latency t_from; - for t_to=int_max earliest_dates.(i_to) (t_from + latency) - to latest_dates.(i_to) - do - Printf.fprintf channel "+1 %s " (pb_var i_to t_to) - done; - Printf.fprintf channel "-1 %s " (pb_var i_from t_from); - Printf.fprintf channel ">= 0\n" - - and gen_delta_constraint i_from i_to latency = - if delta_encoding - then Printf.fprintf channel "l_%d_%d_%d: +1 t%d -1 t%d >= %d\n" - i_from i_to latency i_to i_from latency - - in - - Printf.fprintf channel "\\ nr_instructions=%d deadline=%d\n" nr_instructions deadline; - begin - match pb_type with - | SATISFIABILITY -> output_string channel "Minimize dummy: 0\n" - | OPTIMIZATION -> - Printf.fprintf channel "Minimize\nmakespan: t%d\n" nr_instructions - end; - output_string channel "Subject To\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - Printf.fprintf channel "\\ t[%d] in %d..%d\ntimes%d: " i early late i; - for t=early to late - do - Printf.fprintf channel "+1 %s " (pb_var i t) - done; - Printf.fprintf channel "= 1\n" - done; - - for t=0 to deadline-1 - do - for j=0 to nr_resources-1 - do - let bound = problem.resource_bounds.(j) - and coeffs = ref [] in - for i=0 to nr_instructions-1 - do - let usage = problem.instruction_usages.(i).(j) in - if t >= earliest_dates.(i) && t <= latest_dates.(i) - && usage > 0 - then coeffs := (i, usage) :: !coeffs - done; - if !coeffs <> [] then - begin - Printf.fprintf channel "\\ resource #%d at t=%d <= %d\nr%d_%d: " j t bound j t; - List.iter (fun (i, usage) -> - Printf.fprintf channel "%+d %s " (-usage) (pb_var i t)) !coeffs; - Printf.fprintf channel ">= %d\n" (-bound) - end - done - done; - - List.iter - (fun ctr -> - if ctr.instr_to < nr_instructions then - begin - gen_delta_constraint ctr.instr_from ctr.instr_to ctr.latency; - begin - if direct_encoding - then - for t_to=earliest_dates.(ctr.instr_to) to latest_dates.(ctr.instr_to) - do - gen_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_to - done - end; - begin - if reverse_encoding - then - for t_from=earliest_dates.(ctr.instr_from) to latest_dates.(ctr.instr_from) - do - gen_dual_latency_constraint ctr.instr_to ctr.instr_from ctr.latency t_from - done - end - end - ) problem.latency_constraints; - - begin - match pb_type with - | SATISFIABILITY -> () - | OPTIMIZATION -> - let final_latencies = Array.make nr_instructions 1 in - List.iter (fun (i, latency) -> - final_latencies.(i) <- int_max final_latencies.(i) latency) - predecessors.(nr_instructions); - for i_from = 0 to nr_instructions -1 - do - gen_delta_constraint i_from nr_instructions final_latencies.(i_from) - done; - for t_to=earliest_dates.(nr_instructions) to deadline - do - for i_from = 0 to nr_instructions -1 - do - gen_latency_constraint nr_instructions i_from final_latencies.(i_from) t_to - done - done - end; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - Printf.fprintf channel "ct%d : -1 t%d" i i; - let early = earliest_dates.(i) and late= latest_dates.(i) in - for t=early to late do - Printf.fprintf channel " +%d %s" t (pb_var i t) - done; - output_string channel " = 0\n" - done; - output_string channel "Bounds\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - begin - Printf.fprintf channel "%d <= t%d <= %d\n" early i late; - if true then - for t=early to late do - Printf.fprintf channel "0 <= %s <= 1\n" (pb_var i t) - done - end - done; - output_string channel "Integer\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - Printf.fprintf channel "t%d " i - done; - output_string channel "\nBinary\n"; - for i=0 to (match pb_type with - | OPTIMIZATION -> nr_instructions - | SATISFIABILITY -> nr_instructions-1) - do - let early = earliest_dates.(i) and late= latest_dates.(i) in - for t=early to late do - output_string channel (pb_var i t); - output_string channel " " - done; - output_string channel "\n" - done; - output_string channel "End\n"; - { - mapper_pb_type = pb_type; - mapper_nr_instructions = nr_instructions; - mapper_nr_pb_variables = 0; - mapper_earliest_dates = earliest_dates; - mapper_latest_dates = latest_dates; - mapper_var_offsets = [| |]; - mapper_final_predecessors = predecessors.(nr_instructions) - };; - -(* Guess what? Cplex sometimes outputs 11.000000004 instead of integer 11 *) - -let positive_float_round x = truncate (x +. 0.5) - -let float_round (x : float) : int = - if x > 0.0 - then positive_float_round x - else - (positive_float_round (-. x)) - -let rounded_int_of_string x = float_round (float_of_string x) - -let ilp_read_solution mapper channel = - let times = Array.make - (match mapper.mapper_pb_type with - | OPTIMIZATION -> 1+mapper.mapper_nr_instructions - | SATISFIABILITY -> mapper.mapper_nr_instructions) (-1) in - try - while true do - let line = input_line channel in - ( if (String.length line) < 3 - then failwith (Printf.sprintf "bad ilp output: length(line) < 3: %s" line)); - match String.get line 0 with - | 'x' -> () - | 't' -> let space = - try String.index line ' ' - with Not_found -> - failwith "bad ilp output: no t variable number" - in - let tnumber = - try int_of_string (String.sub line 1 (space-1)) - with Failure _ -> - failwith "bad ilp output: not a variable number" - in - (if tnumber < 0 || tnumber >= (Array.length times) - then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times))); - let value = - let s = String.sub line (space+1) ((String.length line)-space-1) in - try rounded_int_of_string s - with Failure _ -> - failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s) - in - (if value < 0 - then failwith "bad ilp output: negative time"); - times.(tnumber) <- value - | '#' -> () - | '0' -> () - | _ -> failwith (Printf.sprintf "bad ilp output: bad variable initial, line = %s" line) - done; - assert false - with End_of_file -> - Array.iteri (fun i x -> - if i<(Array.length times)-1 - && x<0 then raise Unschedulable) times; - times;; - -let ilp_solver = ref "ilp_solver" - -let problem_nr = ref 0 - -let ilp_scheduler pb_type problem = - try - let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr - and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in - incr problem_nr; - let opb_problem = open_out filename_in in - let mapper = ilp_print_problem opb_problem problem pb_type in - close_out opb_problem; - - begin - match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with - | Unix.WEXITED 0 -> - let opb_solution = open_in filename_out in - let ret = adjust_check_solution mapper (ilp_read_solution mapper opb_solution) in - close_in opb_solution; - Some ret - | Unix.WEXITED _ -> failwith "failed to start ilp solver" - | _ -> None - end - with - | Unschedulable -> None;; - -let current_utime_all () = - let t = Unix.times() in - t.Unix.tms_cutime +. t.Unix.tms_utime;; - -let utime_all_fn fn arg = - let utime_start = current_utime_all () in - let output = fn arg in - let utime_end = current_utime_all () in - (output, utime_end -. utime_start);; - -let cascaded_scheduler (problem : problem) = - let (some_initial_solution, list_scheduler_time) = - utime_all_fn (validated_scheduler list_scheduler) problem in - match some_initial_solution with - | None -> None - | Some initial_solution -> - let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in - begin - let latency2 = get_max_latency solution - and latency1 = get_max_latency initial_solution in - Printf.printf "postpass %s: %d, %d, %d, %g, %g\n" - (if latency2 < latency1 then "REOPTIMIZED" else "unchanged") - (get_nr_instructions problem) - latency1 latency2 - list_scheduler_time reoptimizing_time; - flush stdout - end; - Some solution;; - diff --git a/mppa_k1c/InstructionScheduler.mli b/mppa_k1c/InstructionScheduler.mli deleted file mode 100644 index f91c2d06..00000000 --- a/mppa_k1c/InstructionScheduler.mli +++ /dev/null @@ -1,110 +0,0 @@ -(** Schedule instructions on a synchronized pipeline -by David Monniaux, CNRS, VERIMAG *) - -(** A latency constraint: instruction number [instr_to] should be scheduled at least [latency] clock ticks before [instr_from]. - -It is possible to specify [latency]=0, meaning that [instr_to] can be scheduled at the same clock tick as [instr_from], but not before. - -[instr_to] can be the special value equal to the number of instructions, meaning that it refers to the final output latency. *) -type latency_constraint = { - instr_from : int; - instr_to : int; - latency : int; - } - -(** A scheduling problem. - -In addition to the latency constraints, the resource constraints should be satisfied: at every clock tick, the sum of vectors of resources used by the instructions scheduled at that tick does not exceed the resource bounds. -*) -type problem = { - max_latency : int; - (** An optional maximal total latency of the problem, after which the problem is deemed not schedulable. -1 means there should be no maximum. *) - - resource_bounds : int array; - (** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *) - - instruction_usages: int array array; - (** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *) - - latency_constraints : latency_constraint list - (** The latency constraints that must be satisfied *) - };; - -(** Print problem for human readability. *) -val print_problem : out_channel -> problem -> unit;; - -(** Scheduling solution. For {i n} instructions to schedule, and 0≤{i i}<{i n}, position {i i} contains the time to which instruction {i i} should be scheduled. Position {i n} contains the final output latency. *) -type solution = int array - -(** A scheduling algorithm. -The return value [Some x] is a solution [x]. -[None] means that scheduling failed. *) -type scheduler = problem -> solution option;; - -(* DISABLED -(** Schedule the problem optimally by constraint solving using the Gecode solver. *) -external gecode_scheduler : problem -> solution option - = "caml_gecode_schedule_instr" - *) - -(** Get the number the last scheduling time used for an instruction in a solution. -@return The last clock tick used *) -val maximum_slot_used : solution -> int - -(** Validate that a solution is truly a solution of a scheduling problem. -@raise Failure if validation fails *) -val check_schedule : problem -> solution -> unit - -(** Schedule the problem using a greedy list scheduling algorithm, from the start. -The first (according to instruction ordering) instruction that is ready (according to the latency constraints) is scheduled at the current clock tick. -Once a clock tick is full go to the next. - -@return [Some solution] when a solution is found, [None] if not. *) -val list_scheduler : problem -> solution option - -(** Schedule the problem using the order of instructions without any reordering *) -val greedy_scheduler : problem -> solution option - -(** Schedule a problem using a scheduler applied in the opposite direction, e.g. for list scheduling from the end instead of the start. BUGGY *) -val schedule_reversed : scheduler -> problem -> int array option - -(** Schedule a problem from the end using a list scheduler. BUGGY *) -val reverse_list_scheduler : problem -> int array option - -(** Check that a problem is well-formed. -@raise Failure if validation fails *) -val check_problem : problem -> unit - -(** Apply a scheduler and validate the result against the input problem. -@return The solution found -@raise Failure if validation fails *) -val validated_scheduler : scheduler -> problem -> solution option;; - -(** Get max latency from solution -@return Max latency *) -val get_max_latency : solution -> int;; - -(** Get the length of a maximal critical path -@return Max length *) -val maximum_critical_path : problem -> int;; - -(** Apply line scheduler then advanced solver -@return A solution if found *) -val cascaded_scheduler : problem -> solution option;; - -val show_date_ranges : problem -> unit;; - -type pseudo_boolean_problem_type = - | SATISFIABILITY - | OPTIMIZATION;; - -type pseudo_boolean_mapper -val pseudo_boolean_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; -val pseudo_boolean_read_solution : pseudo_boolean_mapper -> in_channel -> solution;; -val pseudo_boolean_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; - -val smt_print_problem : out_channel -> problem -> unit;; - -val ilp_print_problem : out_channel -> problem -> pseudo_boolean_problem_type -> pseudo_boolean_mapper;; - -val ilp_scheduler : pseudo_boolean_problem_type -> problem -> solution option;; diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v deleted file mode 100644 index a242fce2..00000000 --- a/mppa_k1c/Machregs.v +++ /dev/null @@ -1,245 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import String. -Require Import Coqlib. -Require Import Decidableplus. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Op. - -(** ** Machine registers *) - -(** The following type defines the machine registers that can be referenced - as locations. These include: -- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). -- Floating-point registers that can be allocated to RTL pseudo-registers - ([Fxx]). - - The type [mreg] does not include reserved machine registers such as - the zero register (x0), the link register (x1), the stack pointer - (x2), the global pointer (x3), and the thread pointer (x4). - Finally, register x31 is reserved for use as a temporary by the - assembly-code generator [Asmgen]. -*) - -Inductive mreg: Type := - (* Allocatable General Purpose regs. *) - | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 - | R10 | R11 (* | R12 | R13 | R14 *) | R15 (* | R16 *) | R17 | R18 | R19 - | R20 | R21 | R22 | R23 | R24 | R25 | R26 | R27 | R28 | R29 - | R30 | R31 (* | R32 *) | R33 | R34 | R35 | R36 | R37 | R38 | R39 - | R40 | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 | R49 - | R50 | R51 | R52 | R53 | R54 | R55 | R56 | R57 | R58 | R59 - | R60 | R61 | R62 | R63. - -Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. -Proof. decide equality. Defined. -Global Opaque mreg_eq. - -Definition all_mregs := - R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 - :: R10 :: R11 (* :: R12 :: R13 :: R14 *) :: R15 (* :: R16 *) :: R17 :: R18 :: R19 - :: R20 :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 - :: R30 :: R31 (* :: R32 *) :: R33 :: R34 :: R35 :: R36 :: R37 :: R38 :: R39 - :: R40 :: R41 :: R42 :: R43 :: R44 :: R45 :: R46 :: R47 :: R48 :: R49 - :: R50 :: R51 :: R52 :: R53 :: R54 :: R55 :: R56 :: R57 :: R58 :: R59 - :: R60 :: R61 :: R62 :: R63 :: nil. - -Lemma all_mregs_complete: - forall (r: mreg), In r all_mregs. -Proof. - assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity). - intros. specialize (H r). InvBooleans. auto. -Qed. - -Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq. - -Instance Finite_mreg : Finite mreg := { - Finite_elements := all_mregs; - Finite_elements_spec := all_mregs_complete -}. - -Definition mreg_type (r: mreg): typ := Tany64. - -Open Scope positive_scope. - -Module IndexedMreg <: INDEXED_TYPE. - Definition t := mreg. - Definition eq := mreg_eq. - Definition index (r: mreg): positive := - match r with - | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 | R4 => 5 - | R5 => 6 | R6 => 7 | R7 => 8 | R8 => 9 | R9 => 10 - | R10 => 11 | R11 => 12 (* | R12 => 13 | R13 => 14 | R14 => 15 *) - | R15 => 16 (* | R16 => 17 *) | R17 => 18 | R18 => 19 | R19 => 20 - | R20 => 21 | R21 => 22 | R22 => 23 | R23 => 24 | R24 => 25 - | R25 => 26 | R26 => 27 | R27 => 28 | R28 => 29 | R29 => 30 - | R30 => 31 | R31 => 32 (* | R32 => 33 *) | R33 => 34 | R34 => 35 - | R35 => 36 | R36 => 37 | R37 => 38 | R38 => 39 | R39 => 40 - | R40 => 41 | R41 => 42 | R42 => 43 | R43 => 44 | R44 => 45 - | R45 => 46 | R46 => 47 | R47 => 48 | R48 => 49 | R49 => 50 - | R50 => 51 | R51 => 52 | R52 => 53 | R53 => 54 | R54 => 55 - | R55 => 56 | R56 => 57 | R57 => 58 | R58 => 59 | R59 => 60 - | R60 => 61 | R61 => 62 | R62 => 63 | R63 => 64 - end. - - Lemma index_inj: - forall r1 r2, index r1 = index r2 -> r1 = r2. - Proof. - decide_goal. - Qed. -End IndexedMreg. - -Definition is_stack_reg (r: mreg) : bool := false. - -(** ** Names of registers *) - -Local Open Scope string_scope. - -Definition register_names := - ("R0" , R0) :: ("R1" , R1) :: ("R2" , R2) :: ("R3" , R3) :: ("R4" , R4) - :: ("R5" , R5) :: ("R6" , R6) :: ("R7" , R7) :: ("R8" , R8) :: ("R9" , R9) - :: ("R10", R10) :: ("R11", R11) (* :: ("R12", R12) :: ("R13", R13) :: ("R14", R14) *) - :: ("R15", R15) (* :: ("R16", R16) *) :: ("R17", R17) :: ("R18", R18) :: ("R19", R19) - :: ("R20", R20) :: ("R21", R21) :: ("R22", R22) :: ("R23", R23) :: ("R24", R24) - :: ("R25", R25) :: ("R26", R26) :: ("R27", R27) :: ("R28", R28) :: ("R29", R29) - :: ("R30", R30) :: ("R31", R31) (* :: ("R32", R32) *) :: ("R33", R33) :: ("R34", R34) - :: ("R35", R35) :: ("R36", R36) :: ("R37", R37) :: ("R38", R38) :: ("R39", R39) - :: ("R40", R40) :: ("R41", R41) :: ("R42", R42) :: ("R43", R43) :: ("R44", R44) - :: ("R45", R45) :: ("R46", R46) :: ("R47", R47) :: ("R48", R48) :: ("R49", R49) - :: ("R50", R50) :: ("R51", R51) :: ("R52", R52) :: ("R53", R53) :: ("R54", R54) - :: ("R55", R55) :: ("R56", R56) :: ("R57", R57) :: ("R58", R58) :: ("R59", R59) - :: ("R60", R60) :: ("R61", R61) :: ("R62", R62) :: ("R63", R63) :: nil. - -Definition register_by_name (s: string) : option mreg := - let fix assoc (l: list (string * mreg)) : option mreg := - match l with - | nil => None - | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l' - end - in assoc register_names. - -(** ** Destroyed registers, preferred registers *) - -Definition destroyed_by_op (op: operation): list mreg := nil. -(*match op with - | Ointoffloat | Ointuoffloat | Ointofsingle | Ointuofsingle - | Olongoffloat | Olonguoffloat | Olongofsingle | Olonguofsingle - => F6 :: nil - | _ => nil - end. -*) - -Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg := nil. - -Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := nil. - -Definition destroyed_by_cond (cond: condition): list mreg := nil. - -Definition destroyed_by_jumptable: list mreg := R62 :: R63 :: nil. - -Fixpoint destroyed_by_clobber (cl: list string): list mreg := - match cl with - | nil => nil - | c1 :: cl => - match register_by_name c1 with - | Some r => r :: destroyed_by_clobber cl - | None => destroyed_by_clobber cl - end - end. - -Definition destroyed_by_builtin (ef: external_function): list mreg := - match ef with - | EF_inline_asm txt sg clob => destroyed_by_clobber clob - | EF_memcpy sz al => - if Z.leb sz 15 - then R62 :: R63 :: R61 :: nil - else R62 :: R63 :: R61 :: R60 :: nil - | EF_profiling _ _ => R62 :: R63 ::nil - | _ => nil - end. - -Definition destroyed_by_setstack (ty: typ): list mreg := nil. - -Definition destroyed_at_function_entry: list mreg := R17 :: nil. - -Definition temp_for_parent_frame: mreg := R17. (* Temporary used to store the parent frame, where the arguments are *) - -Definition destroyed_at_indirect_call: list mreg := nil. - (* R10 :: R11 :: R12 :: R13 :: R14 :: R15 :: R16 :: R17 :: nil. *) - -Definition mregs_for_operation (op: operation): list (option mreg) * option mreg := (nil, None). - -(* FIXME DMonniaux this seems to be the place for preferred registers for arguments *) -Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) := (nil, nil). - - (* match ef with - | EF_builtin name sg => - if (negb Archi.ptr64) && string_dec name "__builtin_bswap64" then - (Some R6 :: Some R5 :: nil, Some R5 :: Some R6 :: nil) - else - (nil, nil) - | _ => - (nil, nil) - end. *) - -Global Opaque - destroyed_by_op destroyed_by_load destroyed_by_store - destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin - destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame - mregs_for_operation mregs_for_builtin. - -(** Two-address operations. Return [true] if the first argument and - the result must be in the same location *and* are unconstrained - by [mregs_for_operation]. There are two: the pseudo [Ocast32signed], - because it expands to a no-op owing to the representation of 32-bit - integers as their 64-bit sign extension; and [Ocast32unsigned], - because it builds on the same magic no-op. *) - -Definition two_address_op (op: operation) : bool := - match op with - | Ofmaddf | Ofmaddfs - | Ofmsubf | Ofmsubfs - | Omadd | Omaddimm _ - | Omaddl | Omaddlimm _ - | Omsub | Omsubl - | Osel _ _ | Oselimm _ _ | Osellimm _ _ - | Oinsf _ _ | Oinsfl _ _ => true - | _ => false - end. - -(** Constraints on constant propagation for builtins *) - -Definition builtin_constraints (ef: external_function) : - list builtin_arg_constraint := - match ef with - | EF_builtin id sg => - if string_dec id "__builtin_k1_get" then OK_const :: nil - else if string_dec id "__builtin_k1_set" - then OK_const :: OK_default :: nil - else if string_dec id "__builtin_k1_wfxl" - then OK_const :: OK_default :: nil - else if string_dec id "__builtin_k1_wfxm" - then OK_const :: OK_default :: nil - else nil - | EF_vload _ => OK_addressing :: nil - | EF_vstore _ => OK_addressing :: OK_default :: nil - | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil - | EF_annot kind txt targs => map (fun _ => OK_all) targs - | EF_debug kind txt targs => map (fun _ => OK_all) targs - | _ => nil - end. diff --git a/mppa_k1c/Machregsaux.ml b/mppa_k1c/Machregsaux.ml deleted file mode 100644 index 76956959..00000000 --- a/mppa_k1c/Machregsaux.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Auxiliary functions on machine registers *) - -open Camlcoq -open Machregs - -let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31 - -let _ = - List.iter - (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s)) - Machregs.register_names - -let is_scratch_register r = false - -let name_of_register r = - try Some (Hashtbl.find register_names r) with Not_found -> None - -let register_by_name s = - Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s) - -let can_reserve_register r = Conventions1.is_callee_save r - -let class_of_type = function - | AST.Tint | AST.Tlong - | AST.Tfloat | AST.Tsingle -> 0 - | AST.Tany32 | AST.Tany64 -> assert false diff --git a/mppa_k1c/Machregsaux.mli b/mppa_k1c/Machregsaux.mli deleted file mode 100644 index d7117c21..00000000 --- a/mppa_k1c/Machregsaux.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Auxiliary functions on machine registers *) - -val name_of_register: Machregs.mreg -> string option -val register_by_name: string -> Machregs.mreg option -val is_scratch_register: string -> bool -val can_reserve_register: Machregs.mreg -> bool - -val class_of_type: AST.typ -> int diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v deleted file mode 100644 index 4c354d5a..00000000 --- a/mppa_k1c/NeedOp.v +++ /dev/null @@ -1,414 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import AST Integers Floats. -Require Import Values Memory Globalenvs. -Require Import Op RTL. -Require Import NeedDomain. - -(** Neededness analysis for RISC-V operators *) - -Definition op1 (nv: nval) := nv :: nil. -Definition op2 (nv: nval) := nv :: nv :: nil. -Definition op3 (nv: nval) := nv :: nv :: nv :: nil. - -Definition needs_of_condition (cond: condition): list nval := nil. -Definition needs_of_condition0 (cond0: condition0): list nval := nil. - -Definition needs_of_operation (op: operation) (nv: nval): list nval := - match op with - | Omove => op1 nv - | Ointconst n => nil - | Olongconst n => nil - | Ofloatconst n => nil - | Osingleconst n => nil - | Oaddrsymbol id ofs => nil - | Oaddrstack ofs => nil - | Ocast8signed => op1 (sign_ext 8 nv) - | Ocast16signed => op1 (sign_ext 16 nv) - | Oadd => op2 (modarith nv) - | Oaddimm n => op1 (modarith nv) - | Oaddx _ => op2 (default nv) - | Oaddximm _ _ => op1 (default nv) - | Oneg => op1 (modarith nv) - | Osub => op2 (default nv) - | Orevsubimm _ => op1 (default nv) - | Orevsubx _ => op2 (default nv) - | Orevsubximm _ _ => op1 (default nv) - | Omul => op2 (modarith nv) - | Omulimm _ => op1 (modarith nv) - | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv) - | Oand => op2 (bitwise nv) - | Oandimm n => op1 (andimm nv n) - | Onand => op2 (bitwise nv) - | Onandimm n => op1 (andimm nv n) - | Oor => op2 (bitwise nv) - | Oorimm n => op1 (orimm nv n) - | Onor => op2 (bitwise nv) - | Onorimm n => op1 (orimm nv n) - | Oxor => op2 (bitwise nv) - | Oxorimm n => op1 (bitwise nv) - | Onxor => op2 (bitwise nv) - | Onxorimm n => op1 (bitwise nv) - | Onot => op1 (bitwise nv) - | Oandn => op2 (bitwise nv) - | Oandnimm n => op1 (andimm nv n) - | Oorn => op2 (bitwise nv) - | Oornimm n => op1 (orimm nv n) - | Oshl | Oshr | Oshru => op2 (default nv) - | Oshlimm n => op1 (shlimm nv n) - | Oshrimm n => op1 (shrimm nv n) - | Ororimm n => op1 (ror nv n) - | Oshruimm n => op1 (shruimm nv n) - | Oshrximm n => op1 (default nv) - | Omadd => op3 (modarith nv) - | Omaddimm n => op2 (modarith nv) - | Omsub => op3 (modarith nv) - | Omakelong => op2 (default nv) - | Olowlong | Ohighlong => op1 (default nv) - | Ocast32signed => op1 (default nv) - | Ocast32unsigned => op1 (default nv) - | Oaddl => op2 (default nv) - | Oaddlimm n => op1 (default nv) - | Oaddxl _ => op2 (default nv) - | Oaddxlimm _ _ => op1 (default nv) - | Orevsublimm _ => op1 (default nv) - | Orevsubxl _ => op2 (default nv) - | Orevsubxlimm _ _ => op1 (default nv) - | Onegl => op1 (default nv) - | Osubl => op2 (default nv) - | Omull => op2 (default nv) - | Omullimm _ => op1 (default nv) - | Omullhs | Omullhu | Odivl | Odivlu | Omodl | Omodlu => op2 (default nv) - | Oandl => op2 (default nv) - | Oandlimm n => op1 (default nv) - | Onandl => op2 (default nv) - | Onandlimm n => op1 (default nv) - | Oorl => op2 (default nv) - | Oorlimm n => op1 (default nv) - | Onorl => op2 (default nv) - | Onorlimm n => op1 (default nv) - | Oxorl => op2 (default nv) - | Oxorlimm n => op1 (default nv) - | Onxorl => op2 (default nv) - | Onxorlimm n => op1 (default nv) - | Onotl => op1 (default nv) - | Oandnl => op2 (default nv) - | Oandnlimm n => op1 (default nv) - | Oornl => op2 (default nv) - | Oornlimm n => op1 (default nv) - | Oshll | Oshrl | Oshrlu => op2 (default nv) - | Oshllimm n => op1 (default nv) - | Oshrlimm n => op1 (default nv) - | Oshrluimm n => op1 (default nv) - | Oshrxlimm n => op1 (default nv) - | Omaddl => op3 (default nv) - | Omaddlimm n => op2 (default nv) - | Omsubl => op3 (default nv) - | Onegf | Oabsf => op1 (default nv) - | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv) - | Ofmaddf | Ofmsubf => op3 (default nv) - | Onegfs | Oabsfs => op1 (default nv) - | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv) - | Oinvfs => op1 (default nv) - | Ofmaddfs | Ofmsubfs => op3 (default nv) - | Ofloatofsingle | Osingleoffloat => op1 (default nv) - | Ointoffloat | Ointuoffloat => op1 (default nv) - | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv) - | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv) - | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv) - | Ocmp c => needs_of_condition c - | Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv) - | Oinsf _ _ | Oinsfl _ _ => op2 (default nv) - | Osel c ty => nv :: nv :: needs_of_condition0 c - | Oselimm c imm - | Osellimm c imm => nv :: needs_of_condition0 c - end. - -Definition operation_is_redundant (op: operation) (nv: nval): bool := - match op with - | Ocast8signed => sign_ext_redundant 8 nv - | Ocast16signed => sign_ext_redundant 16 nv - | Oandimm n => andimm_redundant nv n - | Oorimm n => orimm_redundant nv n - | _ => false - end. - -Ltac InvAgree := - match goal with - | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree - | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree - | _ => idtac - end. - -Ltac TrivialExists := - match goal with - | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto - | _ => idtac - end. - -Section SOUNDNESS. - -Variable ge: genv. -Variable sp: block. -Variables m1 m2: mem. -Hypothesis PERM: forall b ofs k p, Mem.perm m1 b ofs k p -> Mem.perm m2 b ofs k p. - -Lemma needs_of_condition_sound: - forall cond args b args', - eval_condition cond args m1 = Some b -> - vagree_list args args' (needs_of_condition cond) -> - eval_condition cond args' m2 = Some b. -Proof. - intros. unfold needs_of_condition in H0. - eapply default_needs_of_condition_sound; eauto. -Qed. - -Let valid_pointer_inj: - forall b1 ofs b2 delta, - inject_id b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. - rewrite Mem.valid_pointer_nonempty_perm in *. eauto. -Qed. - -Let weak_valid_pointer_inj: - forall b1 ofs b2 delta, - inject_id b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - unfold inject_id; intros. inv H. rewrite Ptrofs.add_zero. - rewrite Mem.weak_valid_pointer_spec in *. - rewrite ! Mem.valid_pointer_nonempty_perm in *. - destruct H0; [left|right]; eauto. -Qed. - -Let weak_valid_pointer_no_overflow: - forall b1 ofs b2 delta, - inject_id b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. -Proof. - unfold inject_id; intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. -Qed. - -Let valid_different_pointers_inj: - forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> - inject_id b1 = Some (b1', delta1) -> - inject_id b2 = Some (b2', delta2) -> - b1' <> b2' \/ - Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). -Proof. - unfold inject_id; intros. left; congruence. -Qed. - -Lemma needs_of_condition0_sound: - forall cond arg1 b arg2, - eval_condition0 cond arg1 m1 = Some b -> - vagree arg1 arg2 All -> - eval_condition0 cond arg2 m2 = Some b. -Proof. - intros until arg2. - intros Hcond Hagree. - apply eval_condition0_inj with (f := inject_id) (m1 := m1) (v1 := arg1); simpl; auto. - apply val_inject_lessdef. apply lessdef_vagree. assumption. -Qed. - -Lemma addl_sound: - forall v1 w1 v2 w2 x, - vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (Val.addl v1 v2) (Val.addl w1 w2) x. -Proof. - unfold default; intros. - destruct x; simpl in *; trivial. - - unfold Val.addl. - destruct v1; destruct v2; trivial; destruct Archi.ptr64; trivial. - - apply Val.addl_lessdef; trivial. -Qed. - -Lemma subl_lessdef: - forall v1 v1' v2 v2', - Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Val.lessdef (Val.subl v1 v2) (Val.subl v1' v2'). -Proof. - intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto. -Qed. - -Lemma subl_sound: - forall v1 w1 v2 w2 x, - vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (Val.subl v1 v2) (Val.subl w1 w2) x. -Proof. - unfold default; intros. - destruct x; simpl in *; trivial. - - unfold Val.subl. - destruct v1; destruct v2; trivial; destruct Archi.ptr64; simpl; trivial. - destruct (eq_block _ _) ; simpl; trivial. - - apply subl_lessdef; trivial. -Qed. - - -Lemma mull_sound: - forall v1 w1 v2 w2 x, - vagree v1 w1 (default x) -> vagree v2 w2 (default x) -> - vagree (Val.mull v1 v2) (Val.mull w1 w2) x. -Proof. - unfold default; intros. - destruct x; simpl in *; trivial. - - unfold Val.mull. - destruct v1; destruct v2; trivial. - - unfold Val.mull. - destruct v1; destruct v2; trivial. - inv H. inv H0. - trivial. -Qed. - - -Remark default_idem: forall nv, default (default nv) = default nv. -Proof. - destruct nv; simpl; trivial. -Qed. - -Lemma vagree_triple_op_float : - forall f a b c x y z nv, - (vagree a x (default nv)) -> - (vagree b y (default nv)) -> - (vagree c z (default nv)) -> - (vagree (ExtValues.triple_op_float f a b c) - (ExtValues.triple_op_float f x y z) nv). -Proof. - induction nv; - intros Hax Hby Hcz. - - trivial. - - simpl in *. destruct a; simpl; trivial. - destruct b; simpl; trivial. - destruct c; simpl; trivial. - - simpl in *. destruct a; simpl; trivial. - destruct b; simpl; trivial. - destruct c; simpl; trivial. - inv Hax. inv Hby. inv Hcz. - simpl. - constructor. -Qed. - -Lemma vagree_triple_op_single : - forall f a b c x y z nv, - (vagree a x (default nv)) -> - (vagree b y (default nv)) -> - (vagree c z (default nv)) -> - (vagree (ExtValues.triple_op_single f a b c) - (ExtValues.triple_op_single f x y z) nv). -Proof. - induction nv; - intros Hax Hby Hcz. - - trivial. - - simpl in *. destruct a; simpl; trivial. - destruct b; simpl; trivial. - destruct c; simpl; trivial. - - simpl in *. destruct a; simpl; trivial. - destruct b; simpl; trivial. - destruct c; simpl; trivial. - inv Hax. inv Hby. inv Hcz. - simpl. - constructor. -Qed. - -Hint Resolve vagree_triple_op_float vagree_triple_op_single : na. - -Lemma needs_of_operation_sound: - forall op args v nv args', - eval_operation ge (Vptr sp Ptrofs.zero) op args m1 = Some v -> - vagree_list args args' (needs_of_operation op nv) -> - nv <> Nothing -> - exists v', - eval_operation ge (Vptr sp Ptrofs.zero) op args' m2 = Some v' - /\ vagree v v' nv. -Proof. - unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail); - simpl in *; FuncInv; InvAgree; TrivialExists. -- apply sign_ext_sound; auto. compute; auto. -- apply sign_ext_sound; auto. compute; auto. -- apply add_sound; auto. -- apply add_sound; auto with na. -- apply neg_sound; auto. -- apply mul_sound; auto. -- apply mul_sound; auto with na. -- apply and_sound; auto. -- apply andimm_sound; auto. -- apply notint_sound; apply and_sound; auto. -- apply notint_sound; apply andimm_sound; auto. -- apply or_sound; auto. -- apply orimm_sound; auto. -- apply notint_sound; apply or_sound; auto. -- apply notint_sound; apply orimm_sound; auto. -- apply xor_sound; auto. -- apply xor_sound; auto with na. -- apply notint_sound; apply xor_sound; auto. -- apply notint_sound; apply xor_sound; auto with na. -- apply notint_sound; auto. -- apply and_sound; try apply notint_sound; auto with na. -- apply andimm_sound; try apply notint_sound; auto with na. -- apply or_sound; try apply notint_sound; auto with na. -- apply orimm_sound; try apply notint_sound; auto with na. -- apply shlimm_sound; auto. -- apply shrimm_sound; auto. -- apply shruimm_sound; auto. -- apply ror_sound; auto. - (* madd *) -- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. -- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption. -- repeat rewrite ExtValues.sub_add_neg. - apply add_sound; trivial. - apply neg_sound; trivial. - rewrite modarith_idem. - apply mul_sound; - rewrite modarith_idem; trivial. -- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. - erewrite needs_of_condition0_sound by eauto. - apply select_sound; auto. - simpl; auto with na. - (* select imm *) -- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. - { erewrite needs_of_condition0_sound by eauto. - apply select_sound; auto with na. } - simpl; auto with na. - (* select long imm *) -- destruct (eval_condition0 _ _ _) as [b|] eqn:EC. - { erewrite needs_of_condition0_sound by eauto. - apply select_sound; auto with na. } - simpl; auto with na. -Qed. - -Lemma operation_is_redundant_sound: - forall op nv arg1 args v arg1' args', - operation_is_redundant op nv = true -> - eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m1 = Some v -> - vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) -> - vagree v arg1' nv. -Proof. - intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst. -- apply sign_ext_redundant_sound; auto. omega. -- apply sign_ext_redundant_sound; auto. omega. -- apply andimm_redundant_sound; auto. -- apply orimm_redundant_sound; auto. -Qed. - -End SOUNDNESS. diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v deleted file mode 100644 index 544bb081..00000000 --- a/mppa_k1c/Op.v +++ /dev/null @@ -1,1975 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Operators and addressing modes. The abstract syntax and dynamic - semantics for the CminorSel, RTL, LTL and Mach languages depend on the - following types, defined in this library: -- [condition]: boolean conditions for conditional branches; -- [operation]: arithmetic and logical operations; -- [addressing]: addressing modes for load and store operations. - - These types are processor-specific and correspond roughly to what the - processor can compute in one instruction. In other terms, these - types reflect the state of the program after instruction selection. - For a processor-independent set of operations, see the abstract - syntax and dynamic semantics of the Cminor language. -*) - -Require Import BoolEqual Coqlib. -Require Import AST Integers Floats. -Require Import Values ExtValues Memory Globalenvs Events. - -Set Implicit Arguments. - -(** Conditions (boolean-valued operators). *) - -Inductive condition : Type := - | Ccomp (c: comparison) (**r signed integer comparison *) - | Ccompu (c: comparison) (**r unsigned integer comparison *) - | Ccompimm (c: comparison) (n: int) (**r signed integer comparison with a constant *) - | Ccompuimm (c: comparison) (n: int) (**r unsigned integer comparison with a constant *) - | Ccompl (c: comparison) (**r signed 64-bit integer comparison *) - | Ccomplu (c: comparison) (**r unsigned 64-bit integer comparison *) - | Ccomplimm (c: comparison) (n: int64) (**r signed 64-bit integer comparison with a constant *) - | Ccompluimm (c: comparison) (n: int64) (**r unsigned 64-bit integer comparison with a constant *) - | Ccompf (c: comparison) (**r 64-bit floating-point comparison *) - | Cnotcompf (c: comparison) (**r negation of a floating-point comparison *) - | Ccompfs (c: comparison) (**r 32-bit floating-point comparison *) - | Cnotcompfs (c: comparison). (**r negation of a floating-point comparison *) - -Inductive condition0 : Type := - | Ccomp0 (c: comparison) (**r signed integer comparison with 0 *) - | Ccompu0 (c: comparison) (**r unsigned integer comparison with 0 *) - | Ccompl0 (c: comparison) (**r signed 64-bit integer comparison with 0 *) - | Ccomplu0 (c: comparison). (**r unsigned 64-bit integer comparison with 0 *) - -Definition arg_type_of_condition0 (cond: condition0) := - match cond with - | Ccomp0 _ | Ccompu0 _ => Tint - | Ccompl0 _ | Ccomplu0 _ => Tlong - end. - -(** Arithmetic and logical operations. In the descriptions, [rd] is the - result of the operation and [r1], [r2], etc, are the arguments. *) - -Inductive operation : Type := - | Omove (**r [rd = r1] *) - | Ointconst (n: int) (**r [rd] is set to the given integer constant *) - | Olongconst (n: int64) (**r [rd] is set to the given integer constant *) - | Ofloatconst (n: float) (**r [rd] is set to the given float constant *) - | Osingleconst (n: float32)(**r [rd] is set to the given float constant *) - | Oaddrsymbol (id: ident) (ofs: ptrofs) (**r [rd] is set to the address of the symbol plus the given offset *) - | Oaddrstack (ofs: ptrofs) (**r [rd] is set to the stack pointer plus the given offset *) -(*c 32-bit integer arithmetic: *) - | Ocast8signed (**r [rd] is 8-bit sign extension of [r1] *) - | Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *) - | Oadd (**r [rd = r1 + r2] *) - | Oaddimm (n: int) (**r [rd = r1 + n] *) - | Oaddx (shift: shift1_4) (**r [rd = r1 << shift + r2] *) - | Oaddximm (shift: shift1_4) (n: int) (**r [rd = r1 << shift + n] *) - | Oneg (**r [rd = - r1] *) - | Osub (**r [rd = r1 - r2] *) - | Orevsubimm (n: int) (**r [rd = n - r1] *) - | Orevsubx (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) - | Orevsubximm (shift: shift1_4) (n: int) (**r [rd = n -r1 << shift] *) - | Omul (**r [rd = r1 * r2] *) - | Omulimm (n: int) (**r [rd = r1 * n] *) - | Omulhs (**r [rd = high part of r1 * r2, signed] *) - | Omulhu (**r [rd = high part of r1 * r2, unsigned] *) - | Odiv (**r [rd = r1 / r2] (signed) *) - | Odivu (**r [rd = r1 / r2] (unsigned) *) - | Omod (**r [rd = r1 % r2] (signed) *) - | Omodu (**r [rd = r1 % r2] (unsigned) *) - | Oand (**r [rd = r1 & r2] *) - | Oandimm (n: int) (**r [rd = r1 & n] *) - | Onand (**r [rd = ~(r1 & r2)] *) - | Onandimm (n: int) (**r [rd = ~(r1 & n)] *) - | Oor (**r [rd = r1 | r2] *) - | Oorimm (n: int) (**r [rd = r1 | n] *) - | Onor (**r [rd = ~(r1 | r2)] *) - | Onorimm (n: int) (**r [rd = ~(r1 | n)] *) - | Oxor (**r [rd = r1 ^ r2] *) - | Oxorimm (n: int) (**r [rd = r1 ^ n] *) - | Onxor (**r [rd = ~(r1 ^ r2)] *) - | Onxorimm (n: int) (**r [rd = ~(r1 ^ n)] *) - | Onot (**r [rd = ~r1] *) - | Oandn (**r [rd = (~r1) & r2] *) - | Oandnimm (n: int) (**r [rd = (~r1) & n] *) - | Oorn (**r [rd = (~r1) | r2] *) - | Oornimm (n: int) (**r [rd = (~r1) | n] *) - | Oshl (**r [rd = r1 << r2] *) - | Oshlimm (n: int) (**r [rd = r1 << n] *) - | Oshr (**r [rd = r1 >>s r2] (signed) *) - | Oshrimm (n: int) (**r [rd = r1 >>s n] (signed) *) - | Oshru (**r [rd = r1 >>u r2] (unsigned) *) - | Oshruimm (n: int) (**r [rd = r1 >>x n] (unsigned) *) - | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *) - | Ororimm (n: int) (**r rotate right immediate *) - | Omadd (**r [rd = rd + r1 * r2] *) - | Omaddimm (n: int) (**r [rd = rd + r1 * imm] *) - | Omsub (**r [rd = rd - r1 * r2] *) -(*c 64-bit integer arithmetic: *) - | Omakelong (**r [rd = r1 << 32 | r2] *) - | Olowlong (**r [rd = low-word(r1)] *) - | Ohighlong (**r [rd = high-word(r1)] *) - | Ocast32signed (**r [rd] is 32-bit sign extension of [r1] *) - | Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *) - | Oaddl (**r [rd = r1 + r2] *) - | Oaddlimm (n: int64) (**r [rd = r1 + n] *) - | Oaddxl (shift: shift1_4) (**r [rd = r1 << shift + r2] *) - | Oaddxlimm (shift: shift1_4) (n: int64) (**r [rd = r1 << shift + n] *) - | Orevsublimm (n: int64) (**r [rd = n - r1] *) - | Orevsubxl (shift: shift1_4) (**r [rd = r2 -r1 << shift] *) - | Orevsubxlimm (shift: shift1_4) (n: int64) (**r [rd = n -r1 << shift] *) - | Onegl (**r [rd = - r1] *) - | Osubl (**r [rd = r1 - r2] *) - | Omull (**r [rd = r1 * r2] *) - | Omullimm (n: int64) (**r [rd = r1 * n] *) - | Omullhs (**r [rd = high part of r1 * r2, signed] *) - | Omullhu (**r [rd = high part of r1 * r2, unsigned] *) - | Odivl (**r [rd = r1 / r2] (signed) *) - | Odivlu (**r [rd = r1 / r2] (unsigned) *) - | Omodl (**r [rd = r1 % r2] (signed) *) - | Omodlu (**r [rd = r1 % r2] (unsigned) *) - | Oandl (**r [rd = r1 & r2] *) - | Oandlimm (n: int64) (**r [rd = r1 & n] *) - | Onandl (**r [rd = ~(r1 & r2)] *) - | Onandlimm (n: int64) (**r [rd = ~(r1 & n)] *) - | Oorl (**r [rd = r1 | r2] *) - | Oorlimm (n: int64) (**r [rd = r1 | n] *) - | Onorl (**r [rd = ~(r1 | r2)] *) - | Onorlimm (n: int64) (**r [rd = ~(r1 | n)] *) - | Oxorl (**r [rd = r1 ^ r2] *) - | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *) - | Onxorl (**r [rd = ~(r1 ^ r2)] *) - | Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *) - | Onotl (**r [rd = ~r1] *) - | Oandnl (**r [rd = (~r1) & r2] *) - | Oandnlimm (n: int64) (**r [rd = (~r1) & n] *) - | Oornl (**r [rd = (~r1) | r2] *) - | Oornlimm (n: int64) (**r [rd = (~r1) | n] *) - | Oshll (**r [rd = r1 << r2] *) - | Oshllimm (n: int) (**r [rd = r1 << n] *) - | Oshrl (**r [rd = r1 >> r2] (signed) *) - | Oshrlimm (n: int) (**r [rd = r1 >> n] (signed) *) - | Oshrlu (**r [rd = r1 >> r2] (unsigned) *) - | Oshrluimm (n: int) (**r [rd = r1 >> n] (unsigned) *) - | Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *) - | Omaddl (**r [rd = rd + r1 * r2] *) - | Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *) - | Omsubl (**r [rd = rd - r1 * r2] *) -(*c Floating-point arithmetic: *) - | Onegf (**r [rd = - r1] *) - | Oabsf (**r [rd = abs(r1)] *) - | Oaddf (**r [rd = r1 + r2] *) - | Osubf (**r [rd = r1 - r2] *) - | Omulf (**r [rd = r1 * r2] *) - | Odivf (**r [rd = r1 / r2] *) - | Ominf - | Omaxf - | Ofmaddf - | Ofmsubf - | Onegfs (**r [rd = - r1] *) - | Oabsfs (**r [rd = abs(r1)] *) - | Oaddfs (**r [rd = r1 + r2] *) - | Osubfs (**r [rd = r1 - r2] *) - | Omulfs (**r [rd = r1 * r2] *) - | Odivfs (**r [rd = r1 / r2] *) - | Ominfs - | Omaxfs - | Oinvfs - | Ofmaddfs - | Ofmsubfs - | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *) - | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *) -(*c Conversions between int and float: *) - | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *) - | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *) - | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *) - | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *) - | Osingleofint (**r [rd = float32_of_signed_int(r1)] *) - | Osingleofintu (**r [rd = float32_of_unsigned_int(r1)] *) - | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *) - | Olonguoffloat (**r [rd = unsigned_long_of_float64(r1)] *) - | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *) - | Ofloatoflongu (**r [rd = float64_of_unsigned_long(r1)] *) - | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *) - | Olonguofsingle (**r [rd = unsigned_long_of_float32(r1)] *) - | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *) - | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *) -(*c Boolean tests: *) - | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - | Oextfz (stop : Z) (start : Z) - | Oextfs (stop : Z) (start : Z) - | Oextfzl (stop : Z) (start : Z) - | Oextfsl (stop : Z) (start : Z) - | Oinsf (stop : Z) (start : Z) - | Oinsfl (stop : Z) (start : Z) - | Osel (c0 : condition0) (ty : typ) - | Oselimm (c0 : condition0) (imm: int) - | Osellimm (c0 : condition0) (imm: int64). - -(** Addressing modes. [r1], [r2], etc, are the arguments to the - addressing. *) - -Inductive addressing: Type := - | Aindexed2XS (scale : Z) : addressing (**r Address is [r1 + r2 << scale] *) - | Aindexed2 : addressing (**r Address is [r1 + r2] *) - | Aindexed: ptrofs -> addressing (**r Address is [r1 + offset] *) - | Aglobal: ident -> ptrofs -> addressing (**r Address is global plus offset *) - | Ainstack: ptrofs -> addressing. (**r Address is [stack_pointer + offset] *) - -(** Comparison functions (used in modules [CSE] and [Allocation]). *) - -Definition eq_condition (x y: condition) : {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec Int64.eq_dec; intro. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - decide equality. -Defined. - -Definition eq_condition0 (x y: condition0) : {x=y} + {x<>y}. -Proof. - generalize Int.eq_dec Int64.eq_dec; intro. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - decide equality. -Defined. - -Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. -Proof. - generalize ident_eq Ptrofs.eq_dec Z.eq_dec; intros. - decide equality. -Defined. - -Definition eq_shift1_4 (x y : shift1_4): {x=y} + {x<>y}. -Proof. - decide equality. -Defined. - -Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. -Proof. - generalize typ_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros. - decide equality. -Defined. - -(* Alternate definition: -Definition beq_operation: forall (x y: operation), bool. -Proof. - generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition; boolean_equality. -Defined. - -Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}. -Proof. - decidable_equality_from beq_operation. -Defined. -*) - -Global Opaque eq_condition eq_addressing eq_operation. - -(** * Evaluation functions *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation can trigger an - error, e.g. integer division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) - -Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool := - match cond, vl with - | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2 - | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 - | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n) - | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n) - | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2 - | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 - | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n) - | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n) - | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2 - | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2) - | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2 - | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2) - | _, _ => None - end. - -Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool := - match cond with - | Ccomp0 c => Val.cmp_bool c v1 (Vint Int.zero) - | Ccompu0 c => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint Int.zero) - | Ccompl0 c => Val.cmpl_bool c v1 (Vlong Int64.zero) - | Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero) - end. - -Definition negate_condition0 (cond0 : condition0) : condition0 := - match cond0 with - | Ccomp0 c => Ccomp0 (negate_comparison c) - | Ccompu0 c => Ccompu0 (negate_comparison c) - | Ccompl0 c => Ccompl0 (negate_comparison c) - | Ccomplu0 c => Ccomplu0 (negate_comparison c) - end. - -Definition eval_operation - (F V: Type) (genv: Genv.t F V) (sp: val) - (op: operation) (vl: list val) (m: mem): option val := - match op, vl with - | Omove, v1::nil => Some v1 - | Ointconst n, nil => Some (Vint n) - | Olongconst n, nil => Some (Vlong n) - | Ofloatconst n, nil => Some (Vfloat n) - | Osingleconst n, nil => Some (Vsingle n) - | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs) - | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs) - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2) - | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n)) - | Oaddx s14, v1 :: v2 :: nil => Some (addx (int_of_shift1_4 s14) v1 v2) - | Oaddximm s14 n, v1 :: nil => Some (addx (int_of_shift1_4 s14) v1 (Vint n)) - | Oneg, v1 :: nil => Some (Val.neg v1) - | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2) - | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1) - | Orevsubx shift, v1 :: v2 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 v2) - | Orevsubximm shift n, v1 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 (Vint n)) - | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2) - | Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n)) - | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2) - | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2) - | Odiv, v1 :: v2 :: nil => Val.divs v1 v2 - | Odivu, v1 :: v2 :: nil => Val.divu v1 v2 - | Omod, v1 :: v2 :: nil => Val.mods v1 v2 - | Omodu, v1 :: v2 :: nil => Val.modu v1 v2 - | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2) - | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n)) - | Onand, v1 :: v2 :: nil => Some (Val.notint (Val.and v1 v2)) - | Onandimm n, v1 :: nil => Some (Val.notint (Val.and v1 (Vint n))) - | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2) - | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n)) - | Onor, v1 :: v2 :: nil => Some (Val.notint (Val.or v1 v2)) - | Onorimm n, v1 :: nil => Some (Val.notint (Val.or v1 (Vint n))) - | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2) - | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n)) - | Onxor, v1 :: v2 :: nil => Some (Val.notint (Val.xor v1 v2)) - | Onxorimm n, v1 :: nil => Some (Val.notint (Val.xor v1 (Vint n))) - | Onot, v1 :: nil => Some (Val.notint v1) - | Oandn, v1 :: v2 :: nil => Some (Val.and (Val.notint v1) v2) - | Oandnimm n, v1 :: nil => Some (Val.and (Val.notint v1) (Vint n)) - | Oorn, v1 :: v2 :: nil => Some (Val.or (Val.notint v1) v2) - | Oornimm n, v1 :: nil => Some (Val.or (Val.notint v1) (Vint n)) - | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2) - | Oshlimm n, v1 :: nil => Some (Val.shl v1 (Vint n)) - | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2) - | Oshrimm n, v1 :: nil => Some (Val.shr v1 (Vint n)) - | Ororimm n, v1 :: nil => Some (Val.ror v1 (Vint n)) - | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2) - | Oshruimm n, v1 :: nil => Some (Val.shru v1 (Vint n)) - | Oshrximm n, v1::nil => Some (Val.maketotal (Val.shrx v1 (Vint n))) - | Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3)) - | (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n))) - | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3)) - - | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2) - | Olowlong, v1::nil => Some (Val.loword v1) - | Ohighlong, v1::nil => Some (Val.hiword v1) - | Ocast32signed, v1 :: nil => Some (Val.longofint v1) - | Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1) - | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2) - | Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n)) - | Oaddxl s14, v1 :: v2 :: nil => Some (addxl (int_of_shift1_4 s14) v1 v2) - | Oaddxlimm s14 n, v1 :: nil => Some (addxl (int_of_shift1_4 s14) v1 (Vlong n)) - | Onegl, v1::nil => Some (Val.negl v1) - | Osubl, v1::v2::nil => Some (Val.subl v1 v2) - | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1) - | Orevsubxl shift, v1 :: v2 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2) - | Orevsubxlimm shift n, v1 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 (Vlong n)) - | Omull, v1::v2::nil => Some (Val.mull v1 v2) - | Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n)) - | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2) - | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2) - | Odivl, v1::v2::nil => Val.divls v1 v2 - | Odivlu, v1::v2::nil => Val.divlu v1 v2 - | Omodl, v1::v2::nil => Val.modls v1 v2 - | Omodlu, v1::v2::nil => Val.modlu v1 v2 - | Oandl, v1::v2::nil => Some(Val.andl v1 v2) - | Oandlimm n, v1::nil => Some (Val.andl v1 (Vlong n)) - | Onandl, v1::v2::nil => Some(Val.notl (Val.andl v1 v2)) - | Onandlimm n, v1::nil => Some(Val.notl (Val.andl v1 (Vlong n))) - | Oorl, v1::v2::nil => Some(Val.orl v1 v2) - | Oorlimm n, v1::nil => Some (Val.orl v1 (Vlong n)) - | Onorl, v1::v2::nil => Some(Val.notl (Val.orl v1 v2)) - | Onorlimm n, v1::nil => Some(Val.notl (Val.orl v1 (Vlong n))) - | Oxorl, v1::v2::nil => Some(Val.xorl v1 v2) - | Oxorlimm n, v1::nil => Some (Val.xorl v1 (Vlong n)) - | Onxorl, v1::v2::nil => Some(Val.notl (Val.xorl v1 v2)) - | Onxorlimm n, v1::nil => Some(Val.notl (Val.xorl v1 (Vlong n))) - | Onotl, v1 :: nil => Some (Val.notl v1) - | Oandnl, v1 :: v2 :: nil => Some (Val.andl (Val.notl v1) v2) - | Oandnlimm n, v1 :: nil => Some (Val.andl (Val.notl v1) (Vlong n)) - | Oornl, v1 :: v2 :: nil => Some (Val.orl (Val.notl v1) v2) - | Oornlimm n, v1 :: nil => Some (Val.orl (Val.notl v1) (Vlong n)) - | Oshll, v1::v2::nil => Some (Val.shll v1 v2) - | Oshllimm n, v1::nil => Some (Val.shll v1 (Vint n)) - | Oshrl, v1::v2::nil => Some (Val.shrl v1 v2) - | Oshrlimm n, v1::nil => Some (Val.shrl v1 (Vint n)) - | Oshrlu, v1::v2::nil => Some (Val.shrlu v1 v2) - | Oshrluimm n, v1::nil => Some (Val.shrlu v1 (Vint n)) - | Oshrxlimm n, v1::nil => Some (Val.maketotal (Val.shrxl v1 (Vint n))) - | Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3)) - | (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n))) - | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3)) - - | Onegf, v1::nil => Some (Val.negf v1) - | Oabsf, v1::nil => Some (Val.absf v1) - | Oaddf, v1::v2::nil => Some (Val.addf v1 v2) - | Osubf, v1::v2::nil => Some (Val.subf v1 v2) - | Omulf, v1::v2::nil => Some (Val.mulf v1 v2) - | Odivf, v1::v2::nil => Some (Val.divf v1 v2) - | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2) - | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2) - | Ofmaddf, v1::v2::v3::nil => Some (ExtValues.fmaddf v1 v2 v3) - | Ofmsubf, v1::v2::v3::nil => Some (ExtValues.fmsubf v1 v2 v3) - - | Onegfs, v1::nil => Some (Val.negfs v1) - | Oabsfs, v1::nil => Some (Val.absfs v1) - | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2) - | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2) - | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2) - | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2) - | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2) - | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2) - | Oinvfs, v1::nil => Some (ExtValues.invfs v1) - | Ofmaddfs, v1::v2::v3::nil => Some (ExtValues.fmaddfs v1 v2 v3) - | Ofmsubfs, v1::v2::v3::nil => Some (ExtValues.fmsubfs v1 v2 v3) - - | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1) - | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1) - | Ointoffloat, v1::nil => Some (Val.maketotal (Val.intoffloat v1)) - | Ointuoffloat, v1::nil => Some (Val.maketotal (Val.intuoffloat v1)) - | Ointofsingle, v1::nil => Some (Val.maketotal (Val.intofsingle v1)) - | Ointuofsingle, v1::nil => Some (Val.maketotal (Val.intuofsingle v1)) - | Osingleofint, v1::nil => Some (Val.maketotal (Val.singleofint v1)) - | Osingleofintu, v1::nil => Some (Val.maketotal (Val.singleofintu v1)) - | Olongoffloat, v1::nil => Some (Val.maketotal (Val.longoffloat v1)) - | Olonguoffloat, v1::nil => Some (Val.maketotal (Val.longuoffloat v1)) - | Ofloatoflong, v1::nil => Some (Val.maketotal (Val.floatoflong v1)) - | Ofloatoflongu, v1::nil => Some (Val.maketotal (Val.floatoflongu v1)) - | Olongofsingle, v1::nil => Some (Val.maketotal (Val.longofsingle v1)) - | Olonguofsingle, v1::nil => Some (Val.maketotal (Val.longuofsingle v1)) - | Osingleoflong, v1::nil => Some (Val.maketotal (Val.singleoflong v1)) - | Osingleoflongu, v1::nil => Some (Val.maketotal (Val.singleoflongu v1)) - | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m)) - | (Oextfz stop start), v0::nil => Some (extfz stop start v0) - | (Oextfs stop start), v0::nil => Some (extfs stop start v0) - | (Oextfzl stop start), v0::nil => Some (extfzl stop start v0) - | (Oextfsl stop start), v0::nil => Some (extfsl stop start v0) - | (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1) - | (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1) - | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty) - | Oselimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint) - | Osellimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong) - | _, _ => None - end. - -Definition eval_addressing - (F V: Type) (genv: Genv.t F V) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed2XS scale, v1 :: v2 :: nil => Some (Val.addl v1 (Val.shll v2 (Vint (Int.repr scale)))) - | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2) - | Aindexed n, v1 :: nil => Some (Val.offset_ptr v1 n) - | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs) - | Ainstack n, nil => Some (Val.offset_ptr sp n) - | _, _ => None - end. - -Remark eval_addressing_Ainstack: - forall (F V: Type) (genv: Genv.t F V) sp ofs, - eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs). -Proof. - intros. reflexivity. -Qed. - -Remark eval_addressing_Ainstack_inv: - forall (F V: Type) (genv: Genv.t F V) sp ofs vl v, - eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs. -Proof. - unfold eval_addressing; intros; destruct vl; inv H; auto. -Qed. - -Ltac FuncInv := - match goal with - | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => - destruct x; simpl in H; FuncInv - | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => - destruct v; simpl in H; FuncInv - | H: (if Archi.ptr64 then _ else _) = Some _ |- _ => - destruct Archi.ptr64 eqn:?; FuncInv - | H: (Some _ = Some _) |- _ => - injection H; intros; clear H; FuncInv - | H: (None = Some _) |- _ => - discriminate H - | _ => - idtac - end. - -(** * Static typing of conditions, operators and addressing modes. *) - -Definition type_of_condition (c: condition) : list typ := - match c with - | Ccomp _ => Tint :: Tint :: nil - | Ccompu _ => Tint :: Tint :: nil - | Ccompimm _ _ => Tint :: nil - | Ccompuimm _ _ => Tint :: nil - | Ccompl _ => Tlong :: Tlong :: nil - | Ccomplu _ => Tlong :: Tlong :: nil - | Ccomplimm _ _ => Tlong :: nil - | Ccompluimm _ _ => Tlong :: nil - | Ccompf _ => Tfloat :: Tfloat :: nil - | Cnotcompf _ => Tfloat :: Tfloat :: nil - | Ccompfs _ => Tsingle :: Tsingle :: nil - | Cnotcompfs _ => Tsingle :: Tsingle :: nil - end. - -Definition type_of_operation (op: operation) : list typ * typ := - match op with - | Omove => (nil, Tint) (* treated specially *) - | Ointconst _ => (nil, Tint) - | Olongconst _ => (nil, Tlong) - | Ofloatconst f => (nil, Tfloat) - | Osingleconst f => (nil, Tsingle) - | Oaddrsymbol _ _ => (nil, Tptr) - | Oaddrstack _ => (nil, Tptr) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Oadd => (Tint :: Tint :: nil, Tint) - | Oaddimm _ => (Tint :: nil, Tint) - | Oaddx _ => (Tint :: Tint :: nil, Tint) - | Oaddximm _ _ => (Tint :: nil, Tint) - | Oneg => (Tint :: nil, Tint) - | Osub => (Tint :: Tint :: nil, Tint) - | Orevsubimm _ => (Tint :: nil, Tint) - | Orevsubx _ => (Tint :: Tint :: nil, Tint) - | Orevsubximm _ _ => (Tint :: nil, Tint) - | Omul => (Tint :: Tint :: nil, Tint) - | Omulimm _ => (Tint :: nil, Tint) - | Omulhs => (Tint :: Tint :: nil, Tint) - | Omulhu => (Tint :: Tint :: nil, Tint) - | Odiv => (Tint :: Tint :: nil, Tint) - | Odivu => (Tint :: Tint :: nil, Tint) - | Omod => (Tint :: Tint :: nil, Tint) - | Omodu => (Tint :: Tint :: nil, Tint) - | Oand => (Tint :: Tint :: nil, Tint) - | Oandimm _ => (Tint :: nil, Tint) - | Onand => (Tint :: Tint :: nil, Tint) - | Onandimm _ => (Tint :: nil, Tint) - | Oor => (Tint :: Tint :: nil, Tint) - | Oorimm _ => (Tint :: nil, Tint) - | Onor => (Tint :: Tint :: nil, Tint) - | Onorimm _ => (Tint :: nil, Tint) - | Oxor => (Tint :: Tint :: nil, Tint) - | Oxorimm _ => (Tint :: nil, Tint) - | Onxor => (Tint :: Tint :: nil, Tint) - | Onxorimm _ => (Tint :: nil, Tint) - | Onot => (Tint :: nil, Tint) - | Oandn => (Tint :: Tint :: nil, Tint) - | Oandnimm _ => (Tint :: nil, Tint) - | Oorn => (Tint :: Tint :: nil, Tint) - | Oornimm _ => (Tint :: nil, Tint) - | Oshl => (Tint :: Tint :: nil, Tint) - | Oshlimm _ => (Tint :: nil, Tint) - | Oshr => (Tint :: Tint :: nil, Tint) - | Oshrimm _ => (Tint :: nil, Tint) - | Oshru => (Tint :: Tint :: nil, Tint) - | Oshruimm _ => (Tint :: nil, Tint) - | Oshrximm _ => (Tint :: nil, Tint) - | Ororimm _ => (Tint :: nil, Tint) - | Omadd => (Tint :: Tint :: Tint :: nil, Tint) - | Omaddimm _ => (Tint :: Tint :: nil, Tint) - | Omsub => (Tint :: Tint :: Tint :: nil, Tint) - - | Omakelong => (Tint :: Tint :: nil, Tlong) - | Olowlong => (Tlong :: nil, Tint) - | Ohighlong => (Tlong :: nil, Tint) - | Ocast32signed => (Tint :: nil, Tlong) - | Ocast32unsigned => (Tint :: nil, Tlong) - | Oaddl => (Tlong :: Tlong :: nil, Tlong) - | Oaddlimm _ => (Tlong :: nil, Tlong) - | Oaddxl _ => (Tlong :: Tlong :: nil, Tlong) - | Oaddxlimm _ _ => (Tlong :: nil, Tlong) - | Orevsublimm _ => (Tlong :: nil, Tlong) - | Orevsubxl _ => (Tlong :: Tlong :: nil, Tlong) - | Orevsubxlimm _ _ => (Tlong :: nil, Tlong) - | Onegl => (Tlong :: nil, Tlong) - | Osubl => (Tlong :: Tlong :: nil, Tlong) - | Omull => (Tlong :: Tlong :: nil, Tlong) - | Omullimm _ => (Tlong :: nil, Tlong) - | Omullhs => (Tlong :: Tlong :: nil, Tlong) - | Omullhu => (Tlong :: Tlong :: nil, Tlong) - | Odivl => (Tlong :: Tlong :: nil, Tlong) - | Odivlu => (Tlong :: Tlong :: nil, Tlong) - | Omodl => (Tlong :: Tlong :: nil, Tlong) - | Omodlu => (Tlong :: Tlong :: nil, Tlong) - | Oandl => (Tlong :: Tlong :: nil, Tlong) - | Oandlimm _ => (Tlong :: nil, Tlong) - | Onandl => (Tlong :: Tlong :: nil, Tlong) - | Onandlimm _ => (Tlong :: nil, Tlong) - | Oorl => (Tlong :: Tlong :: nil, Tlong) - | Oorlimm _ => (Tlong :: nil, Tlong) - | Onorl => (Tlong :: Tlong :: nil, Tlong) - | Onorlimm _ => (Tlong :: nil, Tlong) - | Oxorl => (Tlong :: Tlong :: nil, Tlong) - | Oxorlimm _ => (Tlong :: nil, Tlong) - | Onxorl => (Tlong :: Tlong :: nil, Tlong) - | Onxorlimm _ => (Tlong :: nil, Tlong) - | Onotl => (Tlong :: nil, Tlong) - | Oandnl => (Tlong :: Tlong :: nil, Tlong) - | Oandnlimm _ => (Tlong :: nil, Tlong) - | Oornl => (Tlong :: Tlong :: nil, Tlong) - | Oornlimm _ => (Tlong :: nil, Tlong) - | Oshll => (Tlong :: Tint :: nil, Tlong) - | Oshllimm _ => (Tlong :: nil, Tlong) - | Oshrl => (Tlong :: Tint :: nil, Tlong) - | Oshrlimm _ => (Tlong :: nil, Tlong) - | Oshrlu => (Tlong :: Tint :: nil, Tlong) - | Oshrluimm _ => (Tlong :: nil, Tlong) - | Oshrxlimm _ => (Tlong :: nil, Tlong) - | Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong) - | Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong) - | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong) - - | Onegf => (Tfloat :: nil, Tfloat) - | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf - | Osubf - | Omulf - | Odivf - | Ominf - | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat) - | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) - - | Onegfs => (Tsingle :: nil, Tsingle) - | Oabsfs => (Tsingle :: nil, Tsingle) - | Oaddfs - | Osubfs - | Omulfs - | Odivfs - | Ominfs - | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle) - | Oinvfs => (Tsingle :: nil, Tsingle) - | Ofmaddfs | Ofmsubfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle) - - | Osingleoffloat => (Tfloat :: nil, Tsingle) - | Ofloatofsingle => (Tsingle :: nil, Tfloat) - | Ointoffloat => (Tfloat :: nil, Tint) - | Ointuoffloat => (Tfloat :: nil, Tint) - | Ointofsingle => (Tsingle :: nil, Tint) - | Ointuofsingle => (Tsingle :: nil, Tint) - | Osingleofint => (Tint :: nil, Tsingle) - | Osingleofintu => (Tint :: nil, Tsingle) - | Olongoffloat => (Tfloat :: nil, Tlong) - | Olonguoffloat => (Tfloat :: nil, Tlong) - | Ofloatoflong => (Tlong :: nil, Tfloat) - | Ofloatoflongu => (Tlong :: nil, Tfloat) - | Olongofsingle => (Tsingle :: nil, Tlong) - | Olonguofsingle => (Tsingle :: nil, Tlong) - | Osingleoflong => (Tlong :: nil, Tsingle) - | Osingleoflongu => (Tlong :: nil, Tsingle) - | Ocmp c => (type_of_condition c, Tint) - | Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint) - | Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong) - | Oinsf _ _ => (Tint :: Tint :: nil, Tint) - | Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong) - | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty) - | Oselimm c ty => (Tint :: arg_type_of_condition0 c :: nil, Tint) - | Osellimm c ty => (Tlong :: arg_type_of_condition0 c :: nil, Tlong) - end. - -(* FIXME: two Tptr ?! *) -Definition type_of_addressing (addr: addressing) : list typ := - match addr with - | Aindexed2XS _ => Tptr :: Tptr :: nil - | Aindexed2 => Tptr :: Tptr :: nil - | Aindexed _ => Tptr :: nil - | Aglobal _ _ => nil - | Ainstack _ => nil - end. - -(** Weak type soundness results for [eval_operation]: - the result values, when defined, are always of the type predicted - by [type_of_operation]. *) - -Section SOUNDNESS. - -Variable A V: Type. -Variable genv: Genv.t A V. - -Remark type_add: - forall v1 v2, Val.has_type (Val.add v1 v2) Tint. -Proof. - intros. unfold Val.has_type, Val.add. destruct Archi.ptr64, v1, v2; auto. -Qed. - -Remark type_addl: - forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong. -Proof. - intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto. -Qed. - -Remark type_sub: - forall v1 v2, Val.has_type (Val.sub v1 v2) Tint. -Proof. - intros. unfold Val.has_type, Val.sub. destruct Archi.ptr64, v1, v2; simpl; auto. - destruct (eq_block _ _); auto. -Qed. - -Remark type_subl: - forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong. -Proof. - intros. unfold Val.has_type, Val.subl. destruct Archi.ptr64, v1, v2; simpl; auto. - destruct (eq_block _ _); auto. -Qed. - -Remark type_shl: - forall v1 v2, Val.has_type (Val.shl v1 v2) Tint. -Proof. - destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. -Qed. - -Remark type_shll: - forall v1 v2, Val.has_type (Val.shll v1 v2) Tlong. -Proof. - destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial. -Qed. - -Lemma type_of_operation_sound: - forall op vl sp v m, - op <> Omove -> - eval_operation genv sp op vl m = Some v -> - Val.has_type v (snd (type_of_operation op)). -Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type). - intros. - destruct op; simpl; simpl in H0; FuncInv; subst; simpl. - (* move *) - - congruence. - (* intconst, longconst, floatconst, singleconst *) - - exact I. - - exact I. - - exact I. - - exact I. - (* addrsymbol *) - - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)... - (* addrstack *) - - destruct sp... - (* castsigned *) - - destruct v0... - - destruct v0... - (* add, addimm *) - - apply type_add. - - apply type_add. - (* addx, addximm *) - - apply type_add. - - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* neg, sub *) - - destruct v0... - - apply type_sub. - (* revsubimm, revsubx, revsubximm *) - - destruct v0... - - apply type_sub. - - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* mul, mulimm, mulhs, mulhu *) - - destruct v0; destruct v1... - - destruct v0... - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* div, divu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero); inv H2... - (* mod, modu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int.eq i0 Int.zero); inv H2... - (* and, andimm *) - - destruct v0; destruct v1... - - destruct v0... - (* nand, nandimm *) - - destruct v0; destruct v1... - - destruct v0... - (* or, orimm *) - - destruct v0; destruct v1... - - destruct v0... - (* nor, norimm *) - - destruct v0; destruct v1... - - destruct v0... - (* xor, xorimm *) - - destruct v0; destruct v1... - - destruct v0... - (* nxor, nxorimm *) - - destruct v0; destruct v1... - - destruct v0... - (* not *) - - destruct v0... - (* andn, andnimm *) - - destruct v0; destruct v1... - - destruct v0... - (* orn, ornimm *) - - destruct v0; destruct v1... - - destruct v0... - (* shl, shlimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... - (* shr, shrimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... - (* shru, shruimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)... - - destruct v0; simpl... destruct (Int.ltu n Int.iwordsize)... - (* shrx *) - - destruct v0; simpl... destruct (Int.ltu n (Int.repr 31)); simpl; trivial. - (* shrimm *) - - destruct v0; simpl... - (* madd *) - - apply type_add. - - apply type_add. - (* msub *) - - apply type_sub. - (* makelong, lowlong, highlong *) - - destruct v0; destruct v1... - - destruct v0... - - destruct v0... - (* cast32 *) - - destruct v0... - - destruct v0... - (* addl, addlimm *) - - apply type_addl. - - apply type_addl. - (* addxl addxlimm *) - - apply type_addl. - - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* negl, subl *) - - destruct v0... - - apply type_subl. - - destruct v0; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - - destruct v0... - - apply type_subl. - (* mull, mullhs, mullhu *) - - destruct v0; destruct v1... - - destruct v0... - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* divl, divlu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero); inv H2... - (* modl, modlu *) - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2... - - destruct v0; destruct v1; simpl in *; inv H0. - destruct (Int64.eq i0 Int64.zero); inv H2... - (* andl, andlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* nandl, nandlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* orl, orlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* norl, norlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* xorl, xorlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* nxorl, nxorlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* notl *) - - destruct v0... - (* andnl, andnlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* ornl, ornlimm *) - - destruct v0; destruct v1... - - destruct v0... - (* shll, shllimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - (* shr, shrimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - (* shru, shruimm *) - - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')... - - destruct v0; simpl... destruct (Int.ltu n Int64.iwordsize')... - (* shrxl *) - - destruct v0; simpl... destruct (Int.ltu n (Int.repr 63)); simpl; trivial. - (* maddl, maddlim *) - - apply type_addl. - - apply type_addl. - (* msubl *) - - apply type_subl. - (* negf, absf *) - - destruct v0... - - destruct v0... - (* addf, subf *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* mulf, divf *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* minf, maxf *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* fmaddf, fmsubf *) - - destruct v0; destruct v1; destruct v2... - - destruct v0; destruct v1; destruct v2... - (* negfs, absfs *) - - destruct v0... - - destruct v0... - (* addfs, subfs *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* mulfs, divfs *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* minfs, maxfs *) - - destruct v0; destruct v1... - - destruct v0; destruct v1... - (* invfs *) - - destruct v0... - (* fmaddfs, fmsubfs *) - - destruct v0; destruct v1; destruct v2... - - destruct v0; destruct v1; destruct v2... - (* singleoffloat, floatofsingle *) - - destruct v0... - - destruct v0... - (* intoffloat, intuoffloat *) - - destruct v0; simpl... destruct (Float.to_int f); simpl; trivial. - - destruct v0; simpl... destruct (Float.to_intu f); simpl; trivial. - (* intofsingle, intuofsingle *) - - destruct v0; simpl... destruct (Float32.to_int f); simpl; trivial. - - destruct v0; simpl... destruct (Float32.to_intu f); simpl; trivial. - (* singleofint, singleofintu *) - - destruct v0; simpl... - - destruct v0; simpl... - (* longoffloat, longuoffloat *) - - destruct v0; simpl... destruct (Float.to_long f); simpl; trivial. - - destruct v0; simpl... destruct (Float.to_longu f); simpl; trivial. - (* floatoflong, floatoflongu *) - - destruct v0; simpl... - - destruct v0; simpl... - (* longofsingle, longuofsingle *) - - destruct v0; simpl... destruct (Float32.to_long f); simpl; trivial. - - destruct v0; simpl... destruct (Float32.to_longu f); simpl; trivial. - (* singleoflong, singleoflongu *) - - destruct v0; simpl... - - destruct v0; simpl... - (* cmp *) - - destruct (eval_condition cond vl m)... destruct b... - (* extfz *) - - unfold extfz. - destruct (is_bitfield _ _). - + destruct v0; simpl; trivial. - + constructor. - (* extfs *) - - unfold extfs. - destruct (is_bitfield _ _). - + destruct v0; simpl; trivial. - + constructor. - (* extfzl *) - - unfold extfzl. - destruct (is_bitfieldl _ _). - + destruct v0; simpl; trivial. - + constructor. - (* extfsl *) - - unfold extfsl. - destruct (is_bitfieldl _ _). - + destruct v0; simpl; trivial. - + constructor. - (* insf *) - - unfold insf, bitfield_mask. - destruct (is_bitfield _ _). - + destruct v0; destruct v1; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - + constructor. - (* insf *) - - unfold insfl, bitfield_mask. - destruct (is_bitfieldl _ _). - + destruct v0; destruct v1; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - + constructor. - (* Osel *) - - unfold Val.select. destruct (eval_condition0 _ _ m). - + apply Val.normalize_type. - + constructor. - (* Oselimm *) - - unfold Val.select. destruct (eval_condition0 _ _ m). - + apply Val.normalize_type. - + constructor. - (* Osellimm *) - - unfold Val.select. destruct (eval_condition0 _ _ m). - + apply Val.normalize_type. - + constructor. -Qed. - -Definition is_trapping_op (op : operation) := - match op with - | Odiv | Odivl | Odivu | Odivlu - | Omod | Omodl | Omodu | Omodlu => true - | _ => false - end. - -Definition args_of_operation op := - if eq_operation op Omove - then 1%nat - else List.length (fst (type_of_operation op)). - -Lemma is_trapping_op_sound: - forall op vl sp m, - is_trapping_op op = false -> - (List.length vl) = args_of_operation op -> - eval_operation genv sp op vl m <> None. -Proof. - unfold args_of_operation. - destruct op; destruct eq_operation; intros; simpl in *; try congruence. - all: try (destruct vl as [ | vh1 vl1]; try discriminate). - all: try (destruct vl1 as [ | vh2 vl2]; try discriminate). - all: try (destruct vl2 as [ | vh3 vl3]; try discriminate). - all: try (destruct vl3 as [ | vh4 vl4]; try discriminate). -Qed. -End SOUNDNESS. - -(** * Manipulating and transforming operations *) - -(** Recognition of move operations. *) - -Definition is_move_operation - (A: Type) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Type) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** [negate_condition cond] returns a condition that is logically - equivalent to the negation of [cond]. *) - -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompl c => Ccompl(negate_comparison c) - | Ccomplu c => Ccomplu(negate_comparison c) - | Ccomplimm c n => Ccomplimm (negate_comparison c) n - | Ccompluimm c n => Ccompluimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Ccompfs c => Cnotcompfs c - | Cnotcompfs c => Ccompfs c - end. - -Lemma eval_negate_condition: - forall cond vl m, - eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m). -Proof. - intros. destruct cond; simpl. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). apply Val.negate_cmp_bool. - repeat (destruct vl; auto). apply Val.negate_cmpu_bool. - repeat (destruct vl; auto). apply Val.negate_cmpl_bool. - repeat (destruct vl; auto). apply Val.negate_cmplu_bool. - repeat (destruct vl; auto). apply Val.negate_cmpl_bool. - repeat (destruct vl; auto). apply Val.negate_cmplu_bool. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto. - repeat (destruct vl; auto). - repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto. -Qed. - -(** Shifting stack-relative references. This is used in [Stacking]. *) - -Definition shift_stack_addressing (delta: Z) (addr: addressing) := - match addr with - | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta)) - | _ => addr - end. - -Definition shift_stack_operation (delta: Z) (op: operation) := - match op with - | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta)) - | _ => op - end. - -Lemma type_shift_stack_addressing: - forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr. -Proof. - intros. destruct addr; auto. -Qed. - -Lemma type_shift_stack_operation: - forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op. -Proof. - intros. destruct op; auto. -Qed. - -Lemma eval_shift_stack_addressing: - forall F V (ge: Genv.t F V) sp addr vl delta, - eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl = - eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl. -Proof. - intros. destruct addr; simpl; auto. destruct vl; auto. - rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. -Qed. - -Lemma eval_shift_stack_operation: - forall F V (ge: Genv.t F V) sp op vl m delta, - eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m = - eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m. -Proof. - intros. destruct op; simpl; auto. destruct vl; auto. - rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto. -Qed. - -(** Offset an addressing mode [addr] by a quantity [delta], so that - it designates the pointer [delta] bytes past the pointer designated - by [addr]. May be undefined, in which case [None] is returned. *) - -Definition offset_addressing (addr: addressing) (delta: Z) : option addressing := - match addr with - | Aindexed2 | Aindexed2XS _ => None - | Aindexed n => Some(Aindexed (Ptrofs.add n (Ptrofs.repr delta))) - | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta))) - | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta))) - end. - -Lemma eval_offset_addressing: - forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v, - offset_addressing addr delta = Some addr' -> - eval_addressing ge sp addr args = Some v -> - Archi.ptr64 = false -> - eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))). -Proof. - intros. - assert (A: forall x n, - Val.offset_ptr x (Ptrofs.add n (Ptrofs.repr delta)) = - Val.add (Val.offset_ptr x n) (Vint (Int.repr delta))). - { intros; destruct x; simpl; auto. rewrite H1. - rewrite Ptrofs.add_assoc. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. } - destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst. -- rewrite A; auto. -- unfold Genv.symbol_address. destruct (Genv.find_symbol ge i); auto. - simpl. rewrite H1. f_equal; f_equal; f_equal. symmetry; auto with ptrofs. -- rewrite A; auto. -Qed. - -(** Operations that are so cheap to recompute that CSE should not factor them out. *) - -Definition is_trivial_op (op: operation) : bool := - match op with - | Omove => true - | Ointconst n => Int.eq (Int.sign_ext 12 n) n - | Olongconst n => Int64.eq (Int64.sign_ext 12 n) n - | Oaddrstack _ => true - | _ => false - end. - -(** Operations that depend on the memory state. *) - -Definition op_depends_on_memory (op: operation) : bool := - match op with - | Ocmp (Ccompu _) => negb Archi.ptr64 - | Ocmp (Ccompuimm _ _) => negb Archi.ptr64 - | Ocmp (Ccomplu _) => Archi.ptr64 - | Ocmp (Ccompluimm _ _) => Archi.ptr64 - - | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64 - | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64 - - | _ => false - end. - -Lemma op_depends_on_memory_correct: - forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2, - op_depends_on_memory op = false -> - eval_operation ge sp op args m1 = eval_operation ge sp op args m2. -Proof. - intros until m2. destruct op; simpl; try congruence. - - destruct cond; simpl; try congruence; - intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. - - destruct c0; simpl; try congruence; - intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. - - destruct c0; simpl; try congruence; - intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. - - destruct c0; simpl; try congruence; - intros SF; auto; rewrite ? negb_false_iff in SF; - unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity. -Qed. - -(** Global variables mentioned in an operation or addressing mode *) - -Definition globals_addressing (addr: addressing) : list ident := - match addr with - | Aglobal s ofs => s :: nil - | _ => nil - end. - -Definition globals_operation (op: operation) : list ident := - match op with - | Oaddrsymbol s ofs => s :: nil - | _ => nil - end. - -(** * Invariance and compatibility properties. *) - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Hypothesis agree_on_symbols: - forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; auto. destruct vl; auto. - unfold Genv.symbol_address. rewrite agree_on_symbols; auto. -Qed. - -Lemma eval_operation_preserved: - forall sp op vl m, - eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. -Proof. - intros. - unfold eval_operation; destruct op; auto. destruct vl; auto. - unfold Genv.symbol_address. rewrite agree_on_symbols; auto. -Qed. - -End GENV_TRANSF. - -(** Compatibility of the evaluation functions with value injections. *) - -Section EVAL_COMPAT. - -Variable F1 F2 V1 V2: Type. -Variable ge1: Genv.t F1 V1. -Variable ge2: Genv.t F2 V2. -Variable f: meminj. - -Variable m1: mem. -Variable m2: mem. - -Hypothesis valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. - -Hypothesis weak_valid_pointer_inj: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. - -Hypothesis weak_valid_pointer_no_overflow: - forall b1 ofs b2 delta, - f b1 = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. - -Hypothesis valid_different_pointers_inj: - forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' \/ - Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)). - -Ltac InvInject := - match goal with - | [ H: Val.inject _ (Vint _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vfloat _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject _ (Vptr _ _) _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ nil _ |- _ ] => - inv H; InvInject - | [ H: Val.inject_list _ (_ :: _) _ |- _ ] => - inv H; InvInject - | _ => idtac - end. - -Lemma eval_condition_inj: - forall cond vl1 vl2 b, - Val.inject_list f vl1 vl2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. -- inv H3; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. -- inv H3; simpl in H0; inv H0; auto. -- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -- inv H3; inv H2; simpl in H0; inv H0; auto. -Qed. - -Lemma eval_condition0_inj: - forall cond v1 v2 b, - Val.inject f v1 v2 -> - eval_condition0 cond v1 m1 = Some b -> - eval_condition0 cond v2 m2 = Some b. -Proof. - intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto. - - inv H; simpl in *; congruence. - - eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies. - - inv H; simpl in *; congruence. - - eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies. -Qed. - -Ltac TrivialExists := - match goal with - | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] => - exists v1; split; auto - | _ => idtac - end. - -Lemma eval_operation_inj: - forall op sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_operation op) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_operation ge1 sp1 op vl1 m1 = Some v1 -> - exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2. -Proof. - intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists. - (* addrsymbol *) - - apply GL; simpl; auto. - (* addrstack *) - - apply Val.offset_ptr_inject; auto. - (* castsigned *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* add, addimm *) - - apply Val.add_inject; auto. - - apply Val.add_inject; auto. - (* addx, addximm *) - - apply Val.add_inject; trivial. - inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - inv H4; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* neg, sub *) - - inv H4; simpl; auto. - - apply Val.sub_inject; auto. - (* revsubimm, revsubx, revsubximm *) - - inv H4; simpl; trivial. - - apply Val.sub_inject; trivial. - inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto. - - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto. - (* mul, mulimm, mulhs, mulhu *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* div, divu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - (* mod, modu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero - || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int.eq i0 Int.zero); inv H2. TrivialExists. - (* and, andimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* nand, nandimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* or, orimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* nor, norimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* xor, xorimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* nxor, nxorimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* not *) - - inv H4; simpl; auto. - (* andn, andnimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* orn, ornimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* shl, shlimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - (* shr, shrimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - (* shru, shruimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int.iwordsize); auto. - (* shrx *) - - inv H4; simpl; auto. - destruct (Int.ltu n (Int.repr 31)); inv H; simpl; auto. - (* rorimm *) - - inv H4; simpl; auto. - (* madd, maddim *) - - inv H2; inv H3; inv H4; simpl; auto. - - inv H2; inv H4; simpl; auto. - (* msub *) - - apply Val.sub_inject; auto. - inv H3; inv H2; simpl; auto. - (* makelong, highlong, lowlong *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* cast32 *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* addl, addlimm *) - - apply Val.addl_inject; auto. - - apply Val.addl_inject; auto. - (* addxl, addxlimm *) - - apply Val.addl_inject; auto. - inv H4; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - - inv H4; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - (* negl, subl *) - - inv H4; simpl; auto. - - apply Val.subl_inject; auto. - inv H4; inv H2; simpl; trivial; - destruct (Int.ltu _ _); simpl; trivial. - - inv H4; simpl; trivial; - destruct (Int.ltu _ _); simpl; trivial. - - inv H4; simpl; auto. - - apply Val.subl_inject; auto. - (* mull, mullhs, mullhu *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* divl, divlu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. - (* modl, modlu *) - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero - || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2. - TrivialExists. - - inv H4; inv H3; simpl in H1; inv H1. simpl. - destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists. - (* andl, andlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* nandl, nandlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* orl, orlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* norl, norlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* xorl, xorlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* nxorl, nxorlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* notl *) - - inv H4; simpl; auto. - (* andnl, andnlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* ornl, ornlimm *) - - inv H4; inv H2; simpl; auto. - - inv H4; simpl; auto. - (* shll, shllimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shr, shrimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shru, shruimm *) - - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto. - - inv H4; simpl; auto. destruct (Int.ltu n Int64.iwordsize'); auto. - (* shrx *) - - inv H4; simpl; auto. - destruct (Int.ltu n (Int.repr 63)); simpl; auto. - - (* maddl, maddlimm *) - - apply Val.addl_inject; auto. - inv H2; inv H3; inv H4; simpl; auto. - - apply Val.addl_inject; auto. - inv H4; inv H2; simpl; auto. - (* msubl, msublimm *) - - apply Val.subl_inject; auto. - inv H2; inv H3; inv H4; simpl; auto. - - (* negf, absf *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* addf, subf *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* mulf, divf *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* minf, maxf *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* fmaddf, fmsubf *) - - inv H4; inv H3; inv H2; simpl; auto. - - inv H4; inv H3; inv H2; simpl; auto. - (* negfs, absfs *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* addfs, subfs *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* mulfs, divfs *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* minfs, maxfs *) - - inv H4; inv H2; simpl; auto. - - inv H4; inv H2; simpl; auto. - (* invfs *) - - inv H4; simpl; auto. - (* fmaddfs, fmsubfs *) - - inv H4; inv H3; inv H2; simpl; auto. - - inv H4; inv H3; inv H2; simpl; auto. - (* singleoffloat, floatofsingle *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* intoffloat, intuoffloat *) - - inv H4; simpl; auto. destruct (Float.to_int f0); simpl; auto. - - inv H4; simpl; auto. destruct (Float.to_intu f0); simpl; auto. - (* intofsingle, intuofsingle *) - - inv H4; simpl; auto. destruct (Float32.to_int f0); simpl; auto. - - inv H4; simpl; auto. destruct (Float32.to_intu f0); simpl; auto. - (* singleofint, singleofintu *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* longoffloat, longuoffloat *) - - inv H4; simpl; auto. destruct (Float.to_long f0); simpl; auto. - - inv H4; simpl; auto. destruct (Float.to_longu f0); simpl; auto. - (* floatoflong, floatoflongu *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* longofsingle, longuofsingle *) - - inv H4; simpl; auto. destruct (Float32.to_long f0); simpl; auto. - - inv H4; simpl; auto. destruct (Float32.to_longu f0); simpl; auto. - (* singleoflong, singleoflongu *) - - inv H4; simpl; auto. - - inv H4; simpl; auto. - (* cmp *) - - subst v1. destruct (eval_condition cond vl1 m1) eqn:?. - exploit eval_condition_inj; eauto. intros EQ; rewrite EQ. - destruct b; simpl; constructor. - simpl; constructor. - - (* extfz *) - - unfold extfz. - destruct (is_bitfield _ _). - + inv H4; trivial. - + trivial. - - (* extfs *) - - unfold extfs. - destruct (is_bitfield _ _). - + inv H4; trivial. - + trivial. - - (* extfzl *) - - unfold extfzl. - destruct (is_bitfieldl _ _). - + inv H4; trivial. - + trivial. - - (* extfsl *) - - unfold extfsl. - destruct (is_bitfieldl _ _). - + inv H4; trivial. - + trivial. - - (* insf *) - - unfold insf. - destruct (is_bitfield _ _). - + inv H4; inv H2; trivial. - simpl. destruct (Int.ltu _ _); trivial. - simpl. trivial. - + trivial. - - (* insfl *) - - unfold insfl. - destruct (is_bitfieldl _ _). - + inv H4; inv H2; trivial. - simpl. destruct (Int.ltu _ _); trivial. - simpl. trivial. - + trivial. - - (* Osel *) - - apply Val.select_inject; trivial. - destruct (eval_condition0 c0 v2 m1) eqn:Hcond. - + right. - symmetry. - eapply eval_condition0_inj; eassumption. - + left. trivial. - - (* Oselimm *) - - apply Val.select_inject; trivial. - destruct (eval_condition0 _ _ _) eqn:Hcond. - + right. - symmetry. - eapply eval_condition0_inj; eassumption. - + left. trivial. - - (* Osellimm *) - - apply Val.select_inject; trivial. - destruct (eval_condition0 _ _ _) eqn:Hcond. - + right. - symmetry. - eapply eval_condition0_inj; eassumption. - + left. trivial. -Qed. - -Lemma eval_addressing_inj: - forall addr sp1 vl1 sp2 vl2 v1, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing ge1 sp1 addr vl1 = Some v1 -> - exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2. -Proof. - intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists. - - apply Val.addl_inject; trivial. - destruct v0; destruct v'0; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial; inv H3. - apply Val.inject_long. - - apply Val.addl_inject; auto. - - apply Val.offset_ptr_inject; auto. - - apply H; simpl; auto. - - apply Val.offset_ptr_inject; auto. -Qed. - -Lemma eval_addressing_inj_none: - forall addr sp1 vl1 sp2 vl2, - (forall id ofs, - In id (globals_addressing addr) -> - Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) -> - Val.inject f sp1 sp2 -> - Val.inject_list f vl1 vl2 -> - eval_addressing ge1 sp1 addr vl1 = None -> - eval_addressing ge2 sp2 addr vl2 = None. -Proof. - intros until vl2. intros Hglobal Hinjsp Hinjvl. - destruct addr; simpl in *. - 1,2: inv Hinjvl; trivial; - inv H0; trivial; - inv H2; trivial; - discriminate. - 2,3: inv Hinjvl; trivial; discriminate. - inv Hinjvl; trivial; inv H0; trivial; - inv H; trivial; discriminate. -Qed. - -End EVAL_COMPAT. - -(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *) - -Section EVAL_LESSDEF. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Remark valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_extends: - forall m1 m2, Mem.extends m1 m2 -> - forall b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true. -Proof. - intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto. -Qed. - -Remark weak_valid_pointer_no_overflow_extends: - forall m1 b1 ofs b2 delta, - Some(b1, 0) = Some(b2, delta) -> - Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true -> - 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned. -Proof. - intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2. -Qed. - -Remark valid_different_pointers_extends: - forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - b1 <> b2 -> - Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true -> - Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true -> - Some(b1, 0) = Some (b1', delta1) -> - Some(b2, 0) = Some (b2', delta2) -> - b1' <> b2' \/ - Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)). -Proof. - intros. inv H2; inv H3. auto. -Qed. - -Lemma eval_condition_lessdef: - forall cond vl1 vl2 b m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - rewrite <- val_inject_list_lessdef. eauto. auto. -Qed. - -Lemma eval_operation_lessdef: - forall sp op vl1 vl2 v1 m1 m2, - Val.lessdef_list vl1 vl2 -> - Mem.extends m1 m2 -> - eval_operation genv sp op vl1 m1 = Some v1 -> - exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_operation genv sp op vl2 m2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_operation_inj with (m1 := m1) (sp1 := sp). - apply valid_pointer_extends; auto. - apply weak_valid_pointer_extends; auto. - apply weak_valid_pointer_no_overflow_extends. - apply valid_different_pointers_extends; auto. - intros. apply val_inject_lessdef. auto. - apply val_inject_lessdef; auto. - eauto. - auto. - destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -Qed. - -Lemma eval_addressing_lessdef: - forall sp addr vl1 vl2 v1, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = Some v1 -> - exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. rewrite val_inject_list_lessdef in H. - assert (exists v2 : val, - eval_addressing genv sp addr vl2 = Some v2 - /\ Val.inject (fun b => Some(b, 0)) v1 v2). - eapply eval_addressing_inj with (sp1 := sp). - intros. rewrite <- val_inject_lessdef; auto. - rewrite <- val_inject_lessdef; auto. - eauto. auto. - destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto. -Qed. - - -Lemma eval_addressing_lessdef_none: - forall sp addr vl1 vl2, - Val.lessdef_list vl1 vl2 -> - eval_addressing genv sp addr vl1 = None -> - eval_addressing genv sp addr vl2 = None. -Proof. - intros until vl2. intros Hlessdef Heval1. - destruct addr; simpl in *. - 1, 2, 4, 5: inv Hlessdef; trivial; - inv H0; trivial; - inv H2; trivial; - discriminate. - inv Hlessdef; trivial. - inv H0; trivial. - discriminate. -Qed. - -End EVAL_LESSDEF. - -(** Compatibility of the evaluation functions with memory injections. *) - -Section EVAL_INJECT. - -Variable F V: Type. -Variable genv: Genv.t F V. -Variable f: meminj. -Hypothesis globals: meminj_preserves_globals genv f. -Variable sp1: block. -Variable sp2: block. -Variable delta: Z. -Hypothesis sp_inj: f sp1 = Some(sp2, delta). - -Remark symbol_address_inject: - forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs). -Proof. - intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto. - exploit (proj1 globals); eauto. intros. - econstructor; eauto. rewrite Ptrofs.add_zero; auto. -Qed. - -Lemma eval_condition_inject: - forall cond vl1 vl2 b m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_condition cond vl1 m1 = Some b -> - eval_condition cond vl2 m2 = Some b. -Proof. - intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. -Qed. - -Lemma eval_addressing_inject: - forall addr vl1 vl2 v1, - Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 -> - exists v2, - eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_addressing. - eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto. - intros. apply symbol_address_inject. - econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. -Qed. - -Lemma eval_addressing_inject_none: - forall addr vl1 vl2, - Val.inject_list f vl1 vl2 -> - eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None -> - eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None. -Proof. - intros. - rewrite eval_shift_stack_addressing. - eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto. - intros. apply symbol_address_inject. - econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. -Qed. - -Lemma eval_operation_inject: - forall op vl1 vl2 v1 m1 m2, - Val.inject_list f vl1 vl2 -> - Mem.inject f m1 m2 -> - eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 -> - exists v2, - eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2 - /\ Val.inject f v1 v2. -Proof. - intros. - rewrite eval_shift_stack_operation. simpl. - eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto. - intros; eapply Mem.valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_val; eauto. - intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto. - intros; eapply Mem.different_pointers_inject; eauto. - intros. apply symbol_address_inject. - econstructor; eauto. rewrite Ptrofs.add_zero_l; auto. -Qed. - -End EVAL_INJECT. - -(** * Handling of builtin arguments *) - -Definition builtin_arg_ok_1 - (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := - match c, ba with - | OK_all, _ => true - | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true - | OK_addrstack, BA_addrstack _ => true - | OK_addressing, BA_addrstack _ => true - | OK_addressing, BA_addptr (BA _) (BA_int _) => true - | OK_addressing, BA_addptr (BA _) (BA_long _) => true - | _, _ => false - end. - -Definition builtin_arg_ok - (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) := - match ba with - | (BA _ | BA_splitlong (BA _) (BA _)) => true - | _ => builtin_arg_ok_1 ba c - end. diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v deleted file mode 100644 index 35f4bbd9..00000000 --- a/mppa_k1c/Peephole.v +++ /dev/null @@ -1,158 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import Asmvliw. -Require Import Values. -Require Import Integers. -Require Import AST. -Require Compopts. - -Definition gpreg_q_list : list gpreg_q := -R0R1 :: R2R3 :: R4R5 :: R6R7 :: R8R9 -:: R10R11 :: R12R13 :: R14R15 :: R16R17 :: R18R19 -:: R20R21 :: R22R23 :: R24R25 :: R26R27 :: R28R29 -:: R30R31 :: R32R33 :: R34R35 :: R36R37 :: R38R39 -:: R40R41 :: R42R43 :: R44R45 :: R46R47 :: R48R49 -:: R50R51 :: R52R53 :: R54R55 :: R56R57 :: R58R59 -:: R60R61 :: R62R63 :: nil. - -Definition gpreg_o_list : list gpreg_o := -R0R1R2R3 :: R4R5R6R7 :: R8R9R10R11 :: R12R13R14R15 -:: R16R17R18R19 :: R20R21R22R23 :: R24R25R26R27 :: R28R29R30R31 -:: R32R33R34R35 :: R36R37R38R39 :: R40R41R42R43 :: R44R45R46R47 -:: R48R49R50R51 :: R52R53R54R55 :: R56R57R58R59 :: R60R61R62R63 :: nil. - -Fixpoint gpreg_q_search_rec r0 r1 l := - match l with - | h :: t => - let (s0, s1) := gpreg_q_expand h in - if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) - then Some h - else gpreg_q_search_rec r0 r1 t - | nil => None - end. - -Fixpoint gpreg_o_search_rec r0 r1 r2 r3 l := - match l with - | h :: t => - match gpreg_o_expand h with - | (((s0, s1), s2), s3) => - if (gpreg_eq r0 s0) && (gpreg_eq r1 s1) && - (gpreg_eq r2 s2) && (gpreg_eq r3 s3) - then Some h - else gpreg_o_search_rec r0 r1 r2 r3 t - end - | nil => None - end. - -Definition gpreg_q_search (r0 : gpreg) (r1 : gpreg) : option gpreg_q := - gpreg_q_search_rec r0 r1 gpreg_q_list. - -Definition gpreg_o_search r0 r1 r2 r3 : option gpreg_o := - gpreg_o_search_rec r0 r1 r2 r3 gpreg_o_list. - -Parameter print_found_store: forall A, Z -> A -> A. - -Definition coalesce_octuples := true. - -Fixpoint coalesce_mem (insns : list basic) : list basic := - match insns with - | nil => nil - | h0 :: t0 => - match t0 with - | h1 :: t1 => - match h0, h1 with - | (PStoreRRO Psd_a rs0 ra0 ofs0), - (PStoreRRO Psd_a rs1 ra1 ofs1) => - match gpreg_q_search rs0 rs1 with - | Some rs0rs1 => - let zofs0 := Ptrofs.signed ofs0 in - let zofs1 := Ptrofs.signed ofs1 in - if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) - then - if coalesce_octuples - then - match t1 with - | (PStoreRRO Psd_a rs2 ra2 ofs2) :: - (PStoreRRO Psd_a rs3 ra3 ofs3) :: t3 => - match gpreg_o_search rs0 rs1 rs2 rs3 with - | Some octuple => - let zofs2 := Ptrofs.signed ofs2 in - let zofs3 := Ptrofs.signed ofs3 in - if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && - (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) - then (PStore (PStoreORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) - else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - | None => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - end - | _ => (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - end - else (PStore (PStoreQRRO rs0rs1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - else h0 :: (coalesce_mem t0) - | None => h0 :: (coalesce_mem t0) - end - - | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)), - (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) => - match gpreg_q_search rd0 rd1 with - | Some rd0rd1 => - let zofs0 := Ptrofs.signed ofs0 in - let zofs1 := Ptrofs.signed ofs1 in - if (zofs1 =? zofs0 + 8) && (ireg_eq ra0 ra1) && negb (ireg_eq ra0 rd0) - then - if coalesce_octuples - then - match t1 with - | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) :: - (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 => - match gpreg_o_search rd0 rd1 rd2 rd3 with - | Some octuple => - let zofs2 := Ptrofs.signed ofs2 in - let zofs3 := Ptrofs.signed ofs3 in - if (zofs2 =? zofs0 + 16) && (ireg_eq ra0 ra2) && - (zofs3 =? zofs0 + 24) && (ireg_eq ra0 ra3) && - negb (ireg_eq ra0 rd1) && negb (ireg_eq ra0 rd2) - then (PLoad (PLoadORRO octuple ra0 ofs0)) :: Pnop :: Pnop :: Pnop :: (coalesce_mem t3) - else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - | None => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - end - | _ => (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - end - else (PLoad (PLoadQRRO rd0rd1 ra0 ofs0)) :: Pnop :: (coalesce_mem t1) - else h0 :: (coalesce_mem t0) - | None => h0 :: (coalesce_mem t0) - end - | _, _ => h0 :: (coalesce_mem t0) - end - | nil => h0 :: nil - end - end. - -Definition optimize_body (insns : list basic) := - if Compopts.optim_coalesce_mem tt - then coalesce_mem insns - else insns. - -Program Definition optimize_bblock (bb : bblock) := - let optimized := optimize_body (body bb) in - let wf_ok := wf_bblockb optimized (exit bb) in - {| header := header bb; - body := if wf_ok then optimized else (body bb); - exit := exit bb |}. -Next Obligation. - destruct (wf_bblockb (optimize_body (body bb))) eqn:Rwf. - - rewrite Rwf. simpl. trivial. - - exact (correct bb). -Qed. diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v deleted file mode 100644 index 7518866d..00000000 --- a/mppa_k1c/PostpassScheduling.v +++ /dev/null @@ -1,530 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib Errors AST Integers. -Require Import Asmblock Axioms Memory Globalenvs. -Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops. -Require Peephole. - -Local Open Scope error_monad_scope. - -(** Oracle taking as input a basic block, - returns a schedule expressed as a list of bundles *) -Axiom schedule: bblock -> (list (list basic)) * option control. - -Extract Constant schedule => "PostpassSchedulingOracle.schedule". - -Definition state' := L.mem. -Definition outcome' := option state'. - -Definition bblock' := L.bblock. - -Definition exec' := L.run. - -Definition exec := exec_bblock. - -(* Lemmas necessary for defining concat_all *) -Lemma app_nonil {A: Type} (l l': list A) : l <> nil -> l ++ l' <> nil. -Proof. - intros. destruct l; simpl. - - contradiction. - - discriminate. -Qed. - -Lemma app_nonil2 {A: Type} : forall (l l': list A), l' <> nil -> l ++ l' <> nil. -Proof. - destruct l. - - intros. simpl; auto. - - intros. rewrite <- app_comm_cons. discriminate. -Qed. - - - -Definition check_size bb := - if zlt Ptrofs.max_unsigned (size bb) - then Error (msg "PostpassSchedulingproof.check_size") - else OK tt. - -Program Definition concat2 (bb bb': bblock) : res bblock := - do ch <- check_size bb; - do ch' <- check_size bb'; - match (exit bb) with - | None => - match (header bb') with - | nil => - match (exit bb') with - | Some (PExpand (Pbuiltin _ _ _)) => Error (msg "PostpassSchedulingproof.concat2: builtin not alone") - | _ => OK {| header := header bb; body := body bb ++ body bb'; exit := exit bb' |} - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end - | _ => Error (msg "PostpassSchedulingproof.concat2") - end. -Next Obligation. - apply wf_bblock_refl. constructor. - - destruct bb' as [hd' bdy' ex' WF']. destruct bb as [hd bdy ex WF]. simpl in *. - apply wf_bblock_refl in WF'. apply wf_bblock_refl in WF. - inversion_clear WF'. inversion_clear WF. clear H1 H3. - inversion H2; inversion H0. - + left. apply app_nonil. auto. - + right. auto. - + left. apply app_nonil2. auto. - + right. auto. - - unfold builtin_alone. intros. rewrite H0 in H. - assert (Some (PExpand (Pbuiltin ef args res)) <> Some (PExpand (Pbuiltin ef args res))). - apply (H ef args res). contradict H1. auto. -Defined. - -Lemma concat2_zlt_size: - forall a b bb, - concat2 a b = OK bb -> - size a <= Ptrofs.max_unsigned - /\ size b <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. - split. - - unfold check_size in EQ. destruct (zlt Ptrofs.max_unsigned (size a)); monadInv EQ. omega. - - unfold check_size in EQ1. destruct (zlt Ptrofs.max_unsigned (size b)); monadInv EQ1. omega. -Qed. - -Lemma concat2_noexit: - forall a b bb, - concat2 a b = OK bb -> - exit a = None. -Proof. - intros. destruct a as [hd bdy ex WF]; simpl in *. - destruct ex as [e|]; simpl in *; auto. - unfold concat2 in H. simpl in H. monadInv H. -Qed. - -Lemma concat2_decomp: - forall a b bb, - concat2 a b = OK bb -> - body bb = body a ++ body b - /\ exit bb = exit b. -Proof. - intros. exploit concat2_noexit; eauto. intros. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bd ex WF]; simpl in *. - subst exa. - unfold concat2 in H; simpl in H. - destruct hdb. - - destruct exb. - + destruct c. - * destruct i; monadInv H; split; auto. - * monadInv H. split; auto. - + monadInv H. split; auto. - - monadInv H. -Qed. - -Lemma concat2_size: - forall a b bb, concat2 a b = OK bb -> size bb = size a + size b. -Proof. - intros. unfold concat2 in H. - destruct a as [hda bda exa WFa]; destruct b as [hdb bdb exb WFb]; destruct bb as [hd bdy ex WF]; simpl in *. - destruct exa; monadInv H. destruct hdb; try (monadInv EQ2). destruct exb; try (monadInv EQ2). - - destruct c. - + destruct i; monadInv EQ2; - unfold size; simpl; rewrite app_length; rewrite Nat.add_0_r; rewrite <- Nat2Z.inj_add; rewrite Nat.add_assoc; reflexivity. - + monadInv EQ2. unfold size; simpl. rewrite app_length. rewrite Nat.add_0_r. rewrite <- Nat2Z.inj_add. rewrite Nat.add_assoc. reflexivity. - - unfold size; simpl. rewrite app_length. repeat (rewrite Nat.add_0_r). rewrite <- Nat2Z.inj_add. reflexivity. -Qed. - -Lemma concat2_header: - forall bb bb' tbb, - concat2 bb bb' = OK tbb -> header bb = header tbb. -Proof. - intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. - unfold concat2 in H. simpl in H. monadInv H. - destruct ex; try discriminate. destruct hd'; try discriminate. destruct ex'. - - destruct c. - + destruct i; try discriminate; congruence. - + congruence. - - congruence. -Qed. - -Lemma concat2_no_header_in_middle: - forall bb bb' tbb, - concat2 bb bb' = OK tbb -> - header bb' = nil. -Proof. - intros. destruct bb as [hd bdy ex COR]; destruct bb' as [hd' bdy' ex' COR']; destruct tbb as [thd tbdy tex tCOR]; simpl in *. - unfold concat2 in H. simpl in H. monadInv H. - destruct ex; try discriminate. destruct hd'; try discriminate. reflexivity. -Qed. - - - -Fixpoint concat_all (lbb: list bblock) : res bblock := - match lbb with - | nil => Error (msg "PostpassSchedulingproof.concatenate: empty list") - | bb::nil => OK bb - | bb::lbb => - do bb' <- concat_all lbb; - concat2 bb bb' - end. - -Lemma concat_all_size : - forall lbb a bb bb', - concat_all (a :: lbb) = OK bb -> - concat_all lbb = OK bb' -> - size bb = size a + size bb'. -Proof. - intros. unfold concat_all in H. fold concat_all in H. - destruct lbb; try discriminate. - monadInv H. rewrite H0 in EQ. inv EQ. - apply concat2_size. assumption. -Qed. - -Lemma concat_all_header: - forall lbb bb tbb, - concat_all (bb::lbb) = OK tbb -> header bb = header tbb. -Proof. - destruct lbb. - - intros. simpl in H. congruence. - - intros. simpl in H. destruct lbb. - + inv H. eapply concat2_header; eassumption. - + monadInv H. eapply concat2_header; eassumption. -Qed. - -Lemma concat_all_no_header_in_middle: - forall lbb tbb, - concat_all lbb = OK tbb -> - Forall (fun b => header b = nil) (tail lbb). -Proof. - induction lbb; intros; try constructor. - simpl. simpl in H. destruct lbb. - - constructor. - - monadInv H. simpl tl in IHlbb. constructor. - + apply concat2_no_header_in_middle in EQ0. apply concat_all_header in EQ. congruence. - + apply IHlbb in EQ. assumption. -Qed. - -Inductive is_concat : bblock -> list bblock -> Prop := - | mk_is_concat: forall tbb lbb, concat_all lbb = OK tbb -> is_concat tbb lbb. - -Definition verify_schedule (bb bb' : bblock) : res unit := - match bblock_simub bb bb' with - | true => OK tt - | false => Error (msg "PostpassScheduling.verify_schedule") - end. - - -Definition verify_size bb lbb := if (Z.eqb (size bb) (size_blocks lbb)) then OK tt else Error (msg "PostpassScheduling:verify_size: wrong size"). - -Lemma verify_size_size: - forall bb lbb, verify_size bb lbb = OK tt -> size bb = size_blocks lbb. -Proof. - intros. unfold verify_size in H. destruct (size bb =? size_blocks lbb) eqn:SIZE; try discriminate. - apply Z.eqb_eq. assumption. -Qed. - -Lemma verify_schedule_no_header: - forall bb bb', - verify_schedule (no_header bb) bb' = verify_schedule bb bb'. -Proof. - intros. unfold verify_schedule. unfold bblock_simub. unfold pure_bblock_simu_test, bblock_simu_test. rewrite trans_block_noheader_inv. - reflexivity. -Qed. - - -Lemma stick_header_verify_schedule: - forall hd bb' hbb' bb, - stick_header hd bb' = hbb' -> - verify_schedule bb bb' = verify_schedule bb hbb'. -Proof. - intros. unfold verify_schedule. unfold bblock_simub, pure_bblock_simu_test, bblock_simu_test. - rewrite <- H. rewrite trans_block_header_inv. reflexivity. -Qed. - -Lemma check_size_stick_header: - forall bb hd, - check_size bb = check_size (stick_header hd bb). -Proof. - intros. unfold check_size. rewrite stick_header_size. reflexivity. -Qed. - -Lemma stick_header_concat2: - forall bb bb' hd tbb, - concat2 bb bb' = OK tbb -> - concat2 (stick_header hd bb) bb' = OK (stick_header hd tbb). -Proof. - intros. monadInv H. erewrite check_size_stick_header in EQ. - unfold concat2. rewrite EQ. rewrite EQ1. simpl. - destruct bb as [hdr bdy ex COR]; destruct bb' as [hdr' bdy' ex' COR']; simpl in *. - destruct ex; try discriminate. destruct hdr'; try discriminate. destruct ex'. - - destruct c. - + destruct i; try discriminate; inv EQ2; unfold stick_header; simpl; reflexivity. - + inv EQ2. unfold stick_header; simpl. reflexivity. - - inv EQ2. unfold stick_header; simpl. reflexivity. -Qed. - -Lemma stick_header_concat_all: - forall bb c tbb hd, - concat_all (bb :: c) = OK tbb -> - concat_all (stick_header hd bb :: c) = OK (stick_header hd tbb). -Proof. - intros. simpl in *. destruct c; try congruence. - monadInv H. rewrite EQ. simpl. - apply stick_header_concat2. assumption. -Qed. - - - -Definition stick_header_code (h : list label) (lbb : list bblock) := - match (head lbb) with - | None => Error (msg "PostpassScheduling.stick_header: empty schedule") - | Some fst => OK ((stick_header h fst) :: tail lbb) - end. - -Lemma stick_header_code_no_header: - forall bb c, - stick_header_code (header bb) (no_header bb :: c) = OK (bb :: c). -Proof. - intros. unfold stick_header_code. simpl. rewrite stick_header_no_header. reflexivity. -Qed. - -Lemma hd_tl_size: - forall lbb bb, hd_error lbb = Some bb -> size_blocks lbb = size bb + size_blocks (tl lbb). -Proof. - destruct lbb. - - intros. simpl in H. discriminate. - - intros. simpl in H. inv H. simpl. reflexivity. -Qed. - -Lemma stick_header_code_size: - forall h lbb lbb', stick_header_code h lbb = OK lbb' -> size_blocks lbb = size_blocks lbb'. -Proof. - intros. unfold stick_header_code in H. destruct (hd_error lbb) eqn:HD; try discriminate. - inv H. simpl. rewrite stick_header_size. erewrite hd_tl_size; eauto. -Qed. - -Lemma stick_header_code_no_header_in_middle: - forall c h lbb, - stick_header_code h c = OK lbb -> - Forall (fun b => header b = nil) (tl c) -> - Forall (fun b => header b = nil) (tl lbb). -Proof. - destruct c; intros. - - unfold stick_header_code in H. simpl in H. discriminate. - - unfold stick_header_code in H. simpl in H. inv H. simpl in H0. - simpl. assumption. -Qed. - -Lemma stick_header_code_concat_all: - forall hd lbb hlbb tbb, - stick_header_code hd lbb = OK hlbb -> - concat_all lbb = OK tbb -> - exists htbb, - concat_all hlbb = OK htbb - /\ stick_header hd tbb = htbb. -Proof. - intros. exists (stick_header hd tbb). split; auto. - destruct lbb. - - unfold stick_header_code in H. simpl in H. discriminate. - - unfold stick_header_code in H. simpl in H. inv H. - apply stick_header_concat_all. assumption. -Qed. - -Program Definition make_bblock_from_basics lb := - match lb with - | nil => Error (msg "PostpassScheduling.make_bblock_from_basics") - | b :: lb => OK {| header := nil; body := b::lb; exit := None |} - end. - -Fixpoint schedule_to_bblocks_nocontrol llb := - match llb with - | nil => OK nil - | lb :: llb => do bb <- make_bblock_from_basics lb; - do lbb <- schedule_to_bblocks_nocontrol llb; - OK (bb :: lbb) - end. - -Program Definition make_bblock_from_basics_and_control lb c := - match c with - | PExpand (Pbuiltin _ _ _) => Error (msg "PostpassScheduling.make_bblock_from_basics_and_control") - | PCtlFlow cf => OK {| header := nil; body := lb; exit := Some (PCtlFlow cf) |} - end. -Next Obligation. - apply wf_bblock_refl. constructor. - - right. discriminate. - - discriminate. -Qed. - -Fixpoint schedule_to_bblocks_wcontrol llb c := - match llb with - | nil => OK ((bblock_single_inst (PControl c)) :: nil) - | lb :: nil => do bb <- make_bblock_from_basics_and_control lb c; OK (bb :: nil) - | lb :: llb => do bb <- make_bblock_from_basics lb; - do lbb <- schedule_to_bblocks_wcontrol llb c; - OK (bb :: lbb) - end. - -Definition schedule_to_bblocks (llb: list (list basic)) (oc: option control) : res (list bblock) := - match oc with - | None => schedule_to_bblocks_nocontrol llb - | Some c => schedule_to_bblocks_wcontrol llb c - end. - -Definition do_schedule (bb: bblock) : res (list bblock) := - if (Z.eqb (size bb) 1) then OK (bb::nil) - else match (schedule bb) with (llb, oc) => schedule_to_bblocks llb oc end. - -Definition verify_par_bblock (bb: bblock) : res unit := - if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock"). - -Fixpoint verify_par (lbb: list bblock) := - match lbb with - | nil => OK tt - | bb :: lbb => do res <- verify_par_bblock bb; verify_par lbb - end. - -Definition verified_schedule_nob (bb : bblock) : res (list bblock) := - let bb' := no_header bb in - let bb'' := Peephole.optimize_bblock bb' in - do lbb <- do_schedule bb''; - do tbb <- concat_all lbb; - do sizecheck <- verify_size bb lbb; - do schedcheck <- verify_schedule bb' tbb; - do res <- stick_header_code (header bb) lbb; - do parcheck <- verify_par res; - OK res. - -Lemma verified_schedule_nob_size: - forall bb lbb, verified_schedule_nob bb = OK lbb -> size bb = size_blocks lbb. -Proof. - intros. monadInv H. erewrite <- stick_header_code_size; eauto. - apply verify_size_size. - destruct x1; try discriminate. assumption. -Qed. - -Lemma verified_schedule_nob_no_header_in_middle: - forall lbb bb, - verified_schedule_nob bb = OK lbb -> - Forall (fun b => header b = nil) (tail lbb). -Proof. - intros. monadInv H. eapply stick_header_code_no_header_in_middle; eauto. - eapply concat_all_no_header_in_middle. eassumption. -Qed. - -Lemma verified_schedule_nob_header: - forall bb tbb lbb, - verified_schedule_nob bb = OK (tbb :: lbb) -> - header bb = header tbb - /\ Forall (fun b => header b = nil) lbb. -Proof. - intros. split. - - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3. - simpl. reflexivity. - - apply verified_schedule_nob_no_header_in_middle in H. assumption. -Qed. - - -Definition verified_schedule (bb : bblock) : res (list bblock) := - match exit bb with - | Some (PExpand (Pbuiltin ef args res)) => OK (bb::nil) (* Special case for ensuring the lemma verified_schedule_builtin_idem *) - | _ => verified_schedule_nob bb - end. - -Lemma verified_schedule_size: - forall bb lbb, verified_schedule bb = OK lbb -> size bb = size_blocks lbb. -Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. - all: try (apply verified_schedule_nob_size; auto; fail). - inv H. simpl. omega. -Qed. - -Lemma verified_schedule_no_header_in_middle: - forall lbb bb, - verified_schedule bb = OK lbb -> - Forall (fun b => header b = nil) (tail lbb). -Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. - all: try (eapply verified_schedule_nob_no_header_in_middle; eauto; fail). - inv H. simpl. auto. -Qed. - -Lemma verified_schedule_header: - forall bb tbb lbb, - verified_schedule bb = OK (tbb :: lbb) -> - header bb = header tbb - /\ Forall (fun b => header b = nil) lbb. -Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. - all: try (eapply verified_schedule_nob_header; eauto; fail). - inv H. split; simpl; auto. -Qed. - - -Lemma verified_schedule_nob_correct: - forall ge f bb lbb, - verified_schedule_nob bb = OK lbb -> - exists tbb, - is_concat tbb lbb - /\ bblock_simu ge f bb tbb. -Proof. - intros. monadInv H. - exploit stick_header_code_concat_all; eauto. - intros (tbb & CONC & STH). - exists tbb. split; auto. constructor; auto. - rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto. - eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2. - destruct (bblock_simub _ _); auto; try discriminate. -Qed. - -Theorem verified_schedule_correct: - forall ge f bb lbb, - verified_schedule bb = OK lbb -> - exists tbb, - is_concat tbb lbb - /\ bblock_simu ge f bb tbb. -Proof. - intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i. - all: try (eapply verified_schedule_nob_correct; eauto; fail). - inv H. eexists. split; simpl; auto. constructor; auto. simpl; auto. constructor; auto. -Qed. - -Lemma verified_schedule_builtin_idem: - forall bb ef args res lbb, - exit bb = Some (PExpand (Pbuiltin ef args res)) -> - verified_schedule bb = OK lbb -> - lbb = bb :: nil. -Proof. - intros. unfold verified_schedule in H0. rewrite H in H0. inv H0. reflexivity. -Qed. - - -Fixpoint transf_blocks (lbb : list bblock) : res (list bblock) := - match lbb with - | nil => OK nil - | (cons bb lbb) => - do tlbb <- transf_blocks lbb; - do tbb <- verified_schedule bb; - OK (tbb ++ tlbb) - end. - -Definition transl_function (f: function) : res function := - do lb <- transf_blocks (fn_blocks f); - OK (mkfunction (fn_sig f) lb). - -Definition transf_function (f: function) : res function := - do tf <- transl_function f; - if zlt Ptrofs.max_unsigned (size_blocks tf.(fn_blocks)) - then Error (msg "code size exceeded") - else OK tf. - -Definition transf_fundef (f: fundef) : res fundef := - transf_partial_fundef transf_function f. - -Definition transf_program (p: program) : res program := - transform_partial_program transf_fundef p. diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml deleted file mode 100644 index 325f70e5..00000000 --- a/mppa_k1c/PostpassSchedulingOracle.ml +++ /dev/null @@ -1,1029 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -open Asmvliw -open Asmblock -open Printf -open Camlcoq -open InstructionScheduler -open TargetPrinter.Target - -let debug = false - -(** - * Extracting infos from Asmvliw instructions - *) - -type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of offset - -type location = Reg of preg | Mem - -type real_instruction = - (* ALU *) - | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sbfxw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw - | Addd | Andd | Compd | Muld | Ord | Sbfd | Sbfxd | Srad | Srld | Slld | Srsd | Xord - | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd - | Maddw | Maddd | Msbfw | Msbfd | Cmoved - | Make | Nop | Extfz | Extfs | Insf - | Addxw | Addxd - (* LSU *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo - | Sb | Sh | Sw | Sd | Sq | So - (* BCU *) - | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set - (* FPU *) - | Fabsd | Fabsw | Fnegw | Fnegd - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw - | Fmind | Fminw | Fmaxd | Fmaxw | Finvw - | Ffmaw | Ffmad | Ffmsw | Ffmsd - | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz - | Fcompw | Fcompd - -type ab_inst_rec = { - inst: real_instruction; - write_locs : location list; - read_locs : location list; - read_at_id : location list; (* Must be contained in read_locs *) - read_at_e1 : location list; (* idem *) - imm : immediate option; - is_control : bool; -} - -(** Asmvliw constructor to real instructions *) - -exception OpaqueInstruction - -let arith_rr_real = function - | Pcvtl2w -> Addw - | Pmv -> Addd - | Pnegw -> Sbfw - | Pnegl -> Sbfd - | Psxwd -> Extfs - | Pzxwd -> Extfz - | Pextfz(_,_) -> Extfz - | Pextfs(_,_) -> Extfs - | Pextfzl(_,_) -> Extfz - | Pextfsl(_,_) -> Extfs - | Pfabsw -> Fabsw - | Pfabsd -> Fabsd - | Pfnegw -> Fnegw - | Pfnegd -> Fnegd - | Pfinvw -> Finvw - | Pfnarrowdw -> Fnarrowdw - | Pfwidenlwd -> Fwidenlwd - | Pfloatwrnsz -> Floatwz - | Pfloatuwrnsz -> Floatuwz - | Pfloatudrnsz -> Floatudz - | Pfloatdrnsz -> Floatdz - | Pfixedwrzz -> Fixedwz - | Pfixeduwrzz -> Fixeduwz - | Pfixeddrzz -> Fixeddz - | Pfixedudrzz -> Fixedudz - | Pfixeddrzz_i32 -> Fixeddz - | Pfixedudrzz_i32 -> Fixedudz - -let arith_rrr_real = function - | Pcompw it -> Compw - | Pcompl it -> Compd - | Pfcompw ft -> Fcompw - | Pfcompl ft -> Fcompd - | Paddw -> Addw - | Paddxw _ -> Addxw - | Psubw -> Sbfw - | Prevsubxw _ -> Sbfxw - | Pmulw -> Mulw - | Pandw -> Andw - | Pnandw -> Nandw - | Porw -> Orw - | Pnorw -> Norw - | Pxorw -> Xorw - | Pnxorw -> Nxorw - | Pandnw -> Andnw - | Pornw -> Ornw - | Psraw -> Sraw - | Psrlw -> Srlw - | Psrxw -> Srsw - | Psllw -> Sllw - | Paddl -> Addd - | Paddxl _ -> Addxd - | Psubl -> Sbfd - | Prevsubxl _ -> Sbfxd - | Pandl -> Andd - | Pnandl -> Nandd - | Porl -> Ord - | Pnorl -> Nord - | Pxorl -> Xord - | Pnxorl -> Nxord - | Pandnl -> Andnd - | Pornl -> Ornd - | Pmull -> Muld - | Pslll -> Slld - | Psrll -> Srld - | Psrxl -> Srsd - | Psral -> Srad - | Pfaddd -> Faddd - | Pfaddw -> Faddw - | Pfsbfd -> Fsbfd - | Pfsbfw -> Fsbfw - | Pfmuld -> Fmuld - | Pfmulw -> Fmulw - | Pfmind -> Fmind - | Pfminw -> Fminw - | Pfmaxd -> Fmaxd - | Pfmaxw -> Fmaxw - -let arith_rri32_real = function - | Pcompiw it -> Compw - | Paddiw -> Addw - | Paddxiw _ -> Addxw - | Prevsubiw -> Sbfw - | Prevsubxiw _ -> Sbfxw - | Pmuliw -> Mulw - | Pandiw -> Andw - | Pnandiw -> Nandw - | Poriw -> Orw - | Pnoriw -> Norw - | Pxoriw -> Xorw - | Pnxoriw -> Nxorw - | Pandniw -> Andnw - | Porniw -> Ornw - | Psraiw -> Sraw - | Psrxiw -> Srsw - | Psrliw -> Srlw - | Pslliw -> Sllw - | Proriw -> Rorw - | Psllil -> Slld - | Psrlil -> Srld - | Psrail -> Srad - | Psrxil -> Srsd - -let arith_rri64_real = function - | Pcompil it -> Compd - | Paddil -> Addd - | Prevsubil -> Sbfd - | Paddxil _ -> Addxd - | Prevsubxil _ -> Sbfxd - | Pmulil -> Muld - | Pandil -> Andd - | Pnandil -> Nandd - | Poril -> Ord - | Pnoril -> Nord - | Pxoril -> Xord - | Pnxoril -> Nxord - | Pandnil -> Andnd - | Pornil -> Ornd - - -let arith_arr_real = function - | Pinsf (_, _) -> Insf - | Pinsfl (_, _) -> Insf - -let arith_arrr_real = function - | Pfmaddfw -> Ffmaw - | Pfmaddfl -> Ffmad - | Pfmsubfw -> Ffmsw - | Pfmsubfl -> Ffmsd - | Pmaddw -> Maddw - | Pmaddl -> Maddd - | Pmsubw -> Msbfw - | Pmsubl -> Msbfd - | Pcmove _ -> Cmoved - | Pcmoveu _ -> Cmoved - -let arith_arri32_real = function - | Pmaddiw -> Maddw - | Pcmoveiw _ -> Cmoved - | Pcmoveuiw _ -> Cmoved - -let arith_arri64_real = function - | Pmaddil -> Maddd - | Pcmoveil _ -> Cmoved - | Pcmoveuil _ -> Cmoved - -let arith_ri32_real = Make - -let arith_ri64_real = Make - -let arith_rf32_real = Make - -let arith_rf64_real = Make - -let store_real = function - | Psb -> Sb - | Psh -> Sh - | Psw -> Sw - | Psw_a -> Sw - | Psd -> Sd - | Psd_a -> Sd - | Pfss -> Sw - | Pfsd -> Sd - -let load_real = function - | Plb -> Lbs - | Plbu -> Lbz - | Plh -> Lhs - | Plhu -> Lhz - | Plw -> Lws - | Plw_a -> Lws - | Pld -> Ld - | Pld_a -> Ld - | Pfls -> Lws - | Pfld -> Ld - -let set_real = Set -let get_real = Get -let nop_real = Nop -let loadsymbol_real = Make -let loadqrro_real = Lq -let loadorro_real = Lo -let storeqrro_real = Sq -let storeorro_real = So - -let ret_real = Ret -let call_real = Call -let icall_real = Icall -let goto_real = Goto -let igoto_real = Igoto -let jl_real = Goto -let cb_real = Cb -let cbu_real = Cb - -let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let arith_arri32_rec i rd rs imm32 = - let rae1 = match i with Pmaddiw -> [Reg rd] | _ -> [] - in { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false; - read_at_id = [] ; read_at_e1 = rae1 } - -let arith_arri64_rec i rd rs imm64 = - let rae1 = match i with Pmaddil -> [Reg rd] | _ -> [] - in { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false; - read_at_id = []; read_at_e1 = rae1 } - -let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let arith_arrr_rec i rd rs1 rs2 = - let rae1 = match i with Pmaddl | Pmaddw | Pmsubl | Pmsubw -> [Reg rd] | _ -> [] - in { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false; - read_at_id = []; read_at_e1 = rae1 } - -let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let arith_r_rec i rd = match i with - (* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *) - | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); - is_control = false; read_at_id = []; read_at_e1 = [] } - -let arith_rec i = - match i with - | PArithRRI32 (i, rd, rs, imm32) -> arith_rri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) - | PArithRRI64 (i, rd, rs, imm64) -> arith_rri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) - | PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2) - | PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs) - (* Seems like single constant constructor types are elided *) - | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32)) - | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64)) - | PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2) - | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false; - read_at_id = []; read_at_e1 = [] } - | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false; - read_at_id = []; read_at_e1 = [] } - | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} - | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = []; - imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []} - | PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs) - | PArithR (i, rd) -> arith_r_rec i (IR rd) - -let load_rec i = match i with - | PLoadRRO (trap, i, rs1, rs2, imm) -> - { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false; - read_at_id = []; read_at_e1 = [] } - | PLoadQRRO(rs, ra, imm) -> - let (rs0, rs1) = gpreg_q_expand rs in - { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false; - read_at_id = []; read_at_e1 = [] } - | PLoadORRO(rs, ra, imm) -> - let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; - imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []} - | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) -> - { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let store_rec i = match i with - | PStoreRRO (i, rs, ra, imm) -> - { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra)]; imm = (Some (Off imm)); - read_at_id = []; read_at_e1 = [Reg (IR rs)] ; is_control = false} - | PStoreQRRO (rs, ra, imm) -> - let (rs0, rs1) = gpreg_q_expand rs in - { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm)); - read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1)] ; is_control = false} - | PStoreORRO (rs, ra, imm) -> - let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in - { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; - imm = (Some (Off imm)); read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; is_control = false} - | PStoreRRR (i, rs, ra1, ra2) | PStoreRRRXS (i, rs, ra1, ra2) -> - { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra1); Reg (IR ra2)]; imm = None; - read_at_id = []; read_at_e1 = [Reg (IR rs)]; is_control = false} - -let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false; - read_at_id = []; read_at_e1 = [] } - -let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false; - read_at_id = [Reg (IR rs)]; read_at_e1 = [] } - -let basic_rec i = - match i with - | PArith i -> arith_rec i - | PLoad i -> load_rec i - | PStore i -> store_rec i - | Pallocframe (_, _) -> raise OpaqueInstruction - | Pfreeframe (_, _) -> raise OpaqueInstruction - | Pget (rd, rs) -> get_rec rd rs - | Pset (rd, rs) -> set_rec rd rs - | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []} - -let expand_rec = function - | Pbuiltin _ -> raise OpaqueInstruction - -let ctl_flow_rec = function - | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []} - | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} - | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true; - read_at_id = [Reg (IR r)]; read_at_e1 = [] } - | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} - | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true; - read_at_id = [Reg (IR r)]; read_at_e1 = [] } - | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []} - | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; - read_at_id = [Reg (IR rs)]; read_at_e1 = [] } - | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true; - read_at_id = [Reg (IR rs)]; read_at_e1 = [] } - | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *) - -let control_rec i = - match i with - | PExpand i -> expand_rec i - | PCtlFlow i -> ctl_flow_rec i - -let rec basic_recs body = match body with - | [] -> [] - | bi :: body -> (basic_rec bi) :: (basic_recs body) - -let exit_rec exit = match exit with - | None -> [] - | Some ex -> [control_rec ex] - -let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit) - -(** - * Providing informations relative to the real instructions - *) - -(** Abstraction providing all the necessary informations for solving the scheduling problem *) -type inst_info = { - write_locs : location list; - read_locs : location list; - reads_at_id : bool; - reads_at_e1 : bool; - is_control : bool; - usage: int array; (* resources consumed by the instruction *) - latency: int; -} - -(** Figuring out whether an immediate is s10, u27l10 or e27u27l10 *) -type imm_encoding = U6 | S10 | U27L5 | U27L10 | E27U27L10 - -let rec pow a = function - | 0 -> Int64.one - | 1 -> Int64.of_int a - | n -> let b = pow a (n/2) in - Int64.mul b (Int64.mul b (if n mod 2 = 0 then Int64.one else Int64.of_int a)) - -let signed_interval n : (int64 * int64) = begin - assert (n > 0); - let min = Int64.neg @@ pow 2 (n-1) - and max = Int64.sub (pow 2 (n-1)) Int64.one - in (min, max) -end - -let within i interv = match interv with (min, max) -> (i >= min && i <= max) - -let signed_length (i:int64) = - let rec f (i:int64) n = - let interv = signed_interval n - in if (within i interv) then n else f i (n+1) - in f i 1 - -let unsigned_length (i:int64) = (signed_length i) - 1 - -let encode_imm (imm:int64) = - if (Int64.compare imm Int64.zero < 0) then - let length = signed_length imm - in if length <= 10 then S10 - else if length <= 32 then U27L5 - else if length <= 37 then U27L10 - else if length <= 64 then E27U27L10 - else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm - else - let length = unsigned_length imm - in if length <= 6 then U6 - else if length <= 9 then S10 (* Special case for S10 - stay signed no matter what *) - else if length <= 32 then U27L5 - else if length <= 37 then U27L10 - else if length <= 64 then E27U27L10 - else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm - -(** Resources *) -type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop - -let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop] - -let rec find_index elt l = - match l with - | [] -> raise Not_found - | e::l -> if (e == elt) then 0 - else 1 + find_index elt l - -let resource_id resource : int = find_index resource resource_names - -let resource_bound resource : int = - match resource with - | Rissue -> 8 - | Rtiny -> 4 - | Rlite -> 2 - | Rfull -> 1 - | Rlsu -> 1 - | Rmau -> 1 - | Rbcu -> 1 - | Rtca -> 1 - | Rauxr -> 1 - | Rauxw -> 1 - | Rcrrp -> 1 - | Rcrwl -> 1 - | Rcrwh -> 1 - | Rnop -> 4 - -let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names) - -(** Reservation tables *) -let alu_full : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_lite : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_lite_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_lite_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_nop : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rnop -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let alu_tiny_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let bcu : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rbcu -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxr : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxr_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxr_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxw : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxw_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let lsu_auxw_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau_auxr : int array = let resmap = fun r -> match r with - | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau_auxr_x : int array = let resmap = fun r -> match r with - | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -let mau_auxr_y : int array = let resmap = fun r -> match r with - | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0 - in Array.of_list (List.map resmap resource_names) - -(** Real instructions *) - -exception InvalidEncoding - -let rec_to_usage r = - let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i) - | Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr) - - in match r.inst with - | Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw - | Nxorw | Andnw | Ornw -> - (match encoding with None | Some U6 | Some S10 -> alu_tiny - | Some U27L5 | Some U27L10 -> alu_tiny_x - | _ -> raise InvalidEncoding) - | Sbfxw | Sbfxd -> - (match encoding with None -> alu_lite - | Some U6 | Some S10 | Some U27L5 -> alu_lite_x - | _ -> raise InvalidEncoding) - | Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord - | Nxord | Andnd | Ornd -> - (match encoding with None | Some U6 | Some S10 -> alu_tiny - | Some U27L5 | Some U27L10 -> alu_tiny_x - | Some E27U27L10 -> alu_tiny_y) - |Cmoved -> - (match encoding with None | Some U6 | Some S10 -> alu_lite - | Some U27L5 | Some U27L10 -> alu_lite_x - | Some E27U27L10 -> alu_lite_y) - | Addxw -> - (match encoding with None | Some U6 | Some S10 -> alu_lite - | Some U27L5 | Some U27L10 -> alu_lite_x - | _ -> raise InvalidEncoding) - | Addxd -> - (match encoding with None | Some U6 | Some S10 -> alu_lite - | Some U27L5 | Some U27L10 -> alu_lite_x - | Some E27U27L10 -> alu_lite_y) - | Compw -> (match encoding with None -> alu_tiny - | Some U6 | Some S10 | Some U27L5 -> alu_tiny_x - | _ -> raise InvalidEncoding) - | Compd -> (match encoding with None | Some U6 | Some S10 -> alu_tiny - | Some U27L5 | Some U27L10 -> alu_tiny_x - | Some E27U27L10 -> alu_tiny_y) - | Fcompw -> (match encoding with None -> alu_lite - | Some U6 | Some S10 | Some U27L5 -> alu_lite_x - | _ -> raise InvalidEncoding) - | Fcompd -> (match encoding with None -> alu_lite - | Some U6 | Some S10 | Some U27L5 -> alu_lite_x - | _ -> raise InvalidEncoding) - | Make -> (match encoding with Some U6 | Some S10 -> alu_tiny - | Some U27L5 | Some U27L10 -> alu_tiny_x - | Some E27U27L10 -> alu_tiny_y - | _ -> raise InvalidEncoding) - | Maddw -> (match encoding with None -> mau_auxr - | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x - | _ -> raise InvalidEncoding) - | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr - | Some U27L5 | Some U27L10 -> mau_auxr_x - | Some E27U27L10 -> mau_auxr_y) - | Mulw| Msbfw -> (match encoding with None -> mau - | Some U6 | Some S10 | Some U27L5 -> mau_x - | _ -> raise InvalidEncoding) - | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau - | Some U27L5 | Some U27L10 -> mau_x - | Some E27U27L10 -> mau_y) - | Nop -> alu_nop - | Sraw | Srlw | Sllw | Srad | Srld | Slld -> (match encoding with None | Some U6 -> alu_tiny | _ -> raise InvalidEncoding) - (* TODO: check *) - | Srsw | Srsd | Rorw -> (match encoding with None | Some U6 -> alu_lite | _ -> raise InvalidEncoding) - | Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding) - | Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> - (match encoding with None | Some U6 | Some S10 -> lsu_auxw - | Some U27L5 | Some U27L10 -> lsu_auxw_x - | Some E27U27L10 -> lsu_auxw_y) - | Sb | Sh | Sw | Sd | Sq | So -> - (match encoding with None | Some U6 | Some S10 -> lsu_auxr - | Some U27L5 | Some U27L10 -> lsu_auxr_x - | Some E27U27L10 -> lsu_auxr_y) - | Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu - | Get -> bcu_tiny_tiny_mau_xnop - | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd - | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite - | Fnarrowdw -> alu_full - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw - | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau - - -let inst_info_to_dlatency i = - begin - assert (not (i.reads_at_id && i.reads_at_e1)); - match i.reads_at_id with - | true -> +1 - | false -> (match i.reads_at_e1 with - | true -> -1 - | false -> 0) - end - -let real_inst_to_latency = function - | Nop -> 0 (* Only goes through ID *) - | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw - (* TODO check rorw *) - | Rorw | Nandw | Norw | Nxorw | Ornw | Andnw - | Nandd | Nord | Nxord | Ornd | Andnd - | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make - | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd - | Fmind | Fmaxd | Fminw | Fmaxw - -> 1 - | Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4 - | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *) - | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> 3 - | Sb | Sh | Sw | Sd | Sq | So -> 1 (* See k1c-Optimization.pdf page 19 *) - | Get -> 1 - | Set -> 4 (* According to the manual should be 3, but I measured 4 *) - | Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *) - | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1 - | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw - | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4 - -let rec empty_inter la = function - | [] -> true - | b::lb -> if (List.mem b la) then false else empty_inter la lb - -let rec_to_info r : inst_info = - let usage = rec_to_usage r - and latency = real_inst_to_latency r.inst - and reads_at_id = not (empty_inter r.read_locs r.read_at_id) - and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1) - in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control; - reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 } - -let instruction_infos bb = List.map rec_to_info (instruction_recs bb) - -let instruction_usages bb = - let usages = List.map (fun info -> info.usage) (instruction_infos bb) - in Array.of_list usages - -(** - * Latency constraints building - *) - -(* type access = { inst: int; loc: location } *) - -let preg2int pr = Camlcoq.P.to_int @@ Asmblockdeps.ppos pr - -let loc2int = function - | Mem -> 1 - | Reg pr -> preg2int pr - -(* module HashedLoc = struct - type t = { loc: location; key: int } - let equal l1 l2 = (l1.key = l2.key) - let hash l = l.key - let create (l:location) : t = { loc=l; key = loc2int l } -end *) - -(* module LocHash = Hashtbl.Make(HashedLoc) *) -module LocHash = Hashtbl - -(* Hash table : location => list of instruction ids *) - -let rec intlist n = - if n < 0 then failwith "intlist: n < 0" - else if n = 0 then [] - else (n-1) :: (intlist (n-1)) - -let find_in_hash hashloc loc = - match LocHash.find_opt hashloc loc with - | Some idl -> idl - | None -> [] - -(* Returns a list of instruction ids *) -let rec get_accesses hashloc (ll: location list) = match ll with - | [] -> [] - | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs) - -let compute_latency (ifrom: inst_info) (ito: inst_info) = - let dlat = inst_info_to_dlatency ito - in let lat = ifrom.latency + dlat - in assert (lat >= 0); if (lat == 0) then 1 else lat - -let latency_constraints bb = - let written = LocHash.create 70 - and read = LocHash.create 70 - and count = ref 0 - and constraints = ref [] - and instr_infos = instruction_infos bb - in let step (i: inst_info) = - let raw = get_accesses written i.read_locs - and waw = get_accesses written i.write_locs - and war = get_accesses read i.write_locs - in begin - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; - latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw; - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; - latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw; - List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war; - if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count); - (* Updating "read" and "written" hashmaps *) - List.iter (fun loc -> - begin - LocHash.replace written loc [!count]; - LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *) - end) i.write_locs; - List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs; - count := !count + 1 - end - in (List.iter step instr_infos; !constraints) - -(** - * Using the InstructionScheduler - *) - -let build_problem bb = - { max_latency = -1; resource_bounds = resource_bounds; - instruction_usages = instruction_usages bb; latency_constraints = latency_constraints bb } - -let rec find_min_opt (l: int option list) = - match l with - | [] -> None - | e :: l -> - begin match find_min_opt l with - | None -> e - | Some m -> - begin match e with - | None -> Some m - | Some n -> if n < m then Some n else Some m - end - end - -let rec filter_indexes predicate = function - | [] -> [] - | e :: l -> if (predicate e) then e :: (filter_indexes predicate l) else filter_indexes predicate l - -let get_from_indexes indexes l = List.map (List.nth l) indexes - -let is_basic = function PBasic _ -> true | _ -> false -let is_control = function PControl _ -> true | _ -> false -let to_basic = function PBasic i -> i | _ -> failwith "to_basic: control instruction found" -let to_control = function PControl i -> i | _ -> failwith "to_control: basic instruction found" - -let bundlize li hd = - let last = List.nth li (List.length li - 1) - in if is_control last then - let cut_li = Array.to_list @@ Array.sub (Array.of_list li) 0 (List.length li - 1) - in let bli = List.map to_basic cut_li - in { header = hd; body = bli; exit = Some (to_control last) } - else - let bli = List.map to_basic li - in { header = hd; body = bli; exit = None } - -let apply_pbasic b = PBasic b -let extract_some o = match o with Some e -> e | None -> failwith "extract_some: None found" - -let rec find_min = function - | [] -> None - | e :: l -> - match find_min l with - | None -> Some e - | Some m -> if (e < m) then Some e else Some m - -let rec remove_all m = function - | [] -> [] - | e :: l -> if m=e then remove_all m l - else e :: (remove_all m l) - -let rec find_mins l = match find_min l with - | None -> [] - | Some m -> m :: find_mins (remove_all m l) - -let find_all_indices m l = - let rec find m off = function - | [] -> [] - | e :: l -> if m=e then off :: find m (off+1) l - else find m (off+1) l - in find m 0 l - -module TimeHash = Hashtbl - -(* Hash table : time => list of instruction ids *) - -let hashtbl2list h maxint = - let rec f i = match TimeHash.find_opt h i with - | None -> if (i > maxint) then [] else (f (i+1)) - | Some bund -> bund :: (f (i+1)) - in f 0 - -let find_max l = - let rec f = function - | [] -> None - | e :: l -> match f l with - | None -> Some e - | Some m -> if (e > m) then Some e else Some m - in match (f l) with - | None -> raise Not_found - | Some m -> m - -(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *) -let minpack_list (l: int list) = - let timehash = TimeHash.create (List.length l) - in let rec f i = function - | [] -> () - | t::l -> begin - (match TimeHash.find_opt timehash t with - | None -> TimeHash.add timehash t [i] - | Some bund -> TimeHash.replace timehash t (bund @ [i])); - f (i+1) l - end - in begin - f 0 l; - hashtbl2list timehash (find_max l) - end;; - -(* let minpack_list l = - let mins = find_mins l - in List.map (fun m -> find_all_indices m l) mins - *) - -let bb_to_instrs bb = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e]) - -let bundlize_solution bb sol = - let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1)) - in let packs = minpack_list tmp - and instrs = bb_to_instrs bb - in let rec bund hd = function - | [] -> [] - | pack :: packs -> bundlize (get_from_indexes pack instrs) hd :: (bund [] packs) - in bund bb.header packs - -let print_inst oc = function - | Asm.Pallocframe(sz, ofs) -> fprintf oc " Pallocframe\n" - | Asm.Pfreeframe(sz, ofs) -> fprintf oc " Pfreeframe\n" - | Asm.Pbuiltin(ef, args, res) -> fprintf oc " Pbuiltin\n" - | Asm.Pcvtl2w(rd, rs) -> fprintf oc " Pcvtl2w %a = %a\n" ireg rd ireg rs - | i -> print_instruction oc i - -let print_bb oc bb = - let asm_instructions = Asm.unfold_bblock bb - in List.iter (print_inst oc) asm_instructions - -let do_schedule bb = - let problem = build_problem bb - in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then - validated_scheduler cascaded_scheduler - else if !Clflags.option_fpostpass_sched = "list" then - validated_scheduler list_scheduler - else if !Clflags.option_fpostpass_sched = "revlist" then - validated_scheduler reverse_list_scheduler - else if !Clflags.option_fpostpass_sched = "greedy" then - greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem - in match solution with - | None -> failwith "Could not find a valid schedule" - | Some sol -> let bundles = bundlize_solution bb sol in - (if debug then - begin - Printf.eprintf "Scheduling the following group of instructions:\n"; - print_bb stderr bb; - Printf.eprintf "Gave the following solution:\n"; - List.iter (print_bb stderr) bundles; - Printf.eprintf "--------------------------------\n" - end; - bundles) - -(** - * Dumb schedule if the above doesn't work - *) - -let bundlize_label l = - match l with - | [] -> [] - | l -> [{ header = l; body = []; exit = None }] - -let rec bundlize_basic l = - match l with - | [] -> [] - | b :: l -> { header = []; body = [b]; exit = None } :: bundlize_basic l - -let bundlize_exit e = - match e with - | Some e -> [{ header = []; body = []; exit = Some e }] - | None -> [] - -let dumb_schedule (bb : bblock) : bblock list = bundlize_label bb.header @ bundlize_basic bb.body @ bundlize_exit bb.exit - -(** - * Separates the opaque instructions such as Pfreeframe and Pallocframe - *) - -let is_opaque = function - | PBasic (Pallocframe _) | PBasic (Pfreeframe _) | PControl (PExpand (Pbuiltin _)) -> true - | _ -> false - -(* Returns : (accumulated instructions, remaining instructions, opaque instruction if found) *) -let rec biggest_wo_opaque = function - | [] -> ([], [], None) - | i :: li -> if is_opaque i then ([], li, Some i) - else let big, rem, opaque = biggest_wo_opaque li in (i :: big, rem, opaque);; - -let separate_opaque bb = - let instrs = bb_to_instrs bb - in let rec f hd li = - match li with - | [] -> [] - | li -> let big, rem, opaque = biggest_wo_opaque li in - match opaque with - | Some i -> - (match big with - | [] -> (bundlize [i] hd) :: (f [] rem) - | big -> (bundlize big hd) :: (bundlize [i] []) :: (f [] rem) - ) - | None -> (bundlize big hd) :: (f [] rem) - in f bb.header instrs - -let smart_schedule bb = - let lbb = separate_opaque bb - in let rec f = function - | [] -> [] - | bb :: lbb -> - let bundles = - try do_schedule bb - with OpaqueInstruction -> dumb_schedule bb - | e -> - let msg = Printexc.to_string e - and stack = Printexc.get_backtrace () - in begin - Printf.eprintf "In regards to this group of instructions:\n"; - print_bb stderr bb; - Printf.eprintf "Postpass scheduling could not complete: %s\n%s" msg stack; - failwith "Invalid schedule" - (* - Printf.eprintf "Issuing one instruction per bundle instead\n\n"; - dumb_schedule bb - *) - end - in bundles @ (f lbb) - in f lbb - -let bblock_to_bundles bb = - if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb); - (* print_problem (build_problem bb); *) - if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb - -(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *) - -let rec bundles_to_coq_schedule = function - | [] -> ([], None) - | bb :: [] -> ([bb.body], bb.exit) - | bb :: lbb -> let (llb, oc) = bundles_to_coq_schedule lbb in (bb.body :: llb, oc) - -(** Called schedule function from Coq *) - -let schedule_notime bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto -let schedule bb = Timing.time_coq ('P'::('o'::('s'::('t'::('p'::('a'::('s'::('s'::('S'::('c'::('h'::('e'::('d'::('u'::('l'::('i'::('n'::('g'::(' '::('o'::('r'::('a'::('c'::('l'::('e'::([])))))))))))))))))))))))))) schedule_notime bb diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v deleted file mode 100644 index c290387b..00000000 --- a/mppa_k1c/PostpassSchedulingproof.v +++ /dev/null @@ -1,689 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib Errors. -Require Import Integers Floats AST Linking. -Require Import Values Memory Events Globalenvs Smallstep. -Require Import Op Locations Machblock Conventions Asmblock. -Require Import Asmblockgenproof0 Asmblockprops. -Require Import PostpassScheduling. -Require Import Asmblockgenproof. -Require Import Axioms. - -Local Open Scope error_monad_scope. - -Definition match_prog (p tp: Asmvliw.program) := - match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. - -Lemma transf_program_match: - forall p tp, transf_program p = OK tp -> match_prog p tp. -Proof. - intros. eapply match_transform_partial_program; eauto. -Qed. - -Lemma regset_double_set_id: - forall r (rs: regset) v1 v2, - (rs # r <- v1 # r <- v2) = (rs # r <- v2). -Proof. - intros. apply functional_extensionality. intros. destruct (preg_eq r x). - - subst r. repeat (rewrite Pregmap.gss; auto). - - repeat (rewrite Pregmap.gso); auto. -Qed. - -Lemma exec_body_pc_var: - forall l ge rs m rs' m' v, - exec_body ge l rs m = Next rs' m' -> - exec_body ge l (rs # PC <- v) m = Next (rs' # PC <- v) m'. -Proof. - induction l. - - intros. simpl. simpl in H. inv H. auto. - - intros. simpl in *. - destruct (exec_basic_instr ge a rs m) eqn:EXEBI; try discriminate. - erewrite exec_basic_instr_pc_var; eauto. -Qed. - -Lemma pc_set_add: - forall rs v r x y, - 0 <= x <= Ptrofs.max_unsigned -> - 0 <= y <= Ptrofs.max_unsigned -> - rs # r <- (Val.offset_ptr v (Ptrofs.repr (x + y))) = rs # r <- (Val.offset_ptr (rs # r <- (Val.offset_ptr v (Ptrofs.repr x)) r) (Ptrofs.repr y)). -Proof. - intros. apply functional_extensionality. intros r0. destruct (preg_eq r r0). - - subst. repeat (rewrite Pregmap.gss); auto. - destruct v; simpl; auto. - rewrite Ptrofs.add_assoc. - enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto. - unfold Ptrofs.add. - enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto. - repeat (rewrite Ptrofs.unsigned_repr); auto. - - repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma concat2_straight: - forall a b bb rs m rs'' m'' f ge, - concat2 a b = OK bb -> - exec_bblock ge f bb rs m = Next rs'' m'' -> - exists rs' m', - exec_bblock ge f a rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) - /\ exec_bblock ge f b rs' m' = Next rs'' m''. -Proof. - intros until ge. intros CONC2 EXEB. - exploit concat2_zlt_size; eauto. intros (LTA & LTB). - exploit concat2_noexit; eauto. intros EXA. - exploit concat2_decomp; eauto. intros. inv H. - unfold exec_bblock in EXEB. destruct (exec_body ge (body bb) rs m) eqn:EXEB'; try discriminate. - rewrite H0 in EXEB'. apply exec_body_app in EXEB'. destruct EXEB' as (rs1 & m1 & EXEB1 & EXEB2). - eexists; eexists. split. - unfold exec_bblock. rewrite EXEB1. rewrite EXA. simpl. eauto. - split. - exploit exec_body_pc. eapply EXEB1. intros. rewrite <- H. auto. - unfold exec_bblock. unfold nextblock, incrPC. rewrite regset_same_assign. erewrite exec_body_pc_var; eauto. - rewrite <- H1. unfold nextblock in EXEB. rewrite regset_double_set_id. - assert (size bb = size a + size b). - { unfold size. rewrite H0. rewrite H1. rewrite app_length. rewrite EXA. simpl. rewrite Nat.add_0_r. - repeat (rewrite Nat2Z.inj_add). omega. } - clear EXA H0 H1. rewrite H in EXEB. - assert (rs1 PC = rs0 PC). { apply exec_body_pc in EXEB2. auto. } - rewrite H0. rewrite <- pc_set_add; auto. - exploit size_positive. instantiate (1 := a). intro. omega. - exploit size_positive. instantiate (1 := b). intro. omega. -Qed. - -Lemma concat_all_exec_bblock (ge: Genv.t fundef unit) (f: function) : - forall a bb rs m lbb rs'' m'', - lbb <> nil -> - concat_all (a :: lbb) = OK bb -> - exec_bblock ge f bb rs m = Next rs'' m'' -> - exists bb' rs' m', - concat_all lbb = OK bb' - /\ exec_bblock ge f a rs m = Next rs' m' - /\ rs' PC = Val.offset_ptr (rs PC) (Ptrofs.repr (size a)) - /\ exec_bblock ge f bb' rs' m' = Next rs'' m''. -Proof. - intros until m''. intros Hnonil CONC EXEB. - simpl in CONC. - destruct lbb as [|b lbb]; try contradiction. clear Hnonil. - monadInv CONC. exploit concat2_straight; eauto. intros (rs' & m' & EXEB1 & PCeq & EXEB2). - exists x. repeat econstructor. all: eauto. -Qed. - -Lemma ptrofs_add_repr : - forall a b, - Ptrofs.unsigned (Ptrofs.add (Ptrofs.repr a) (Ptrofs.repr b)) = Ptrofs.unsigned (Ptrofs.repr (a + b)). -Proof. - intros a b. - rewrite Ptrofs.add_unsigned. repeat (rewrite Ptrofs.unsigned_repr_eq). - rewrite <- Zplus_mod. auto. -Qed. - -Section PRESERVATION_ASMBLOCK. - -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma transf_function_no_overflow: - forall f tf, - transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned. -Proof. - intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. - omega. -Qed. - -Lemma symbols_preserved: - forall id, - Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_match TRANSL). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSL). - -Lemma functions_translated: - forall v f, - Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial TRANSL). - -Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> - exists tf, - Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial TRANSL). - -Lemma functions_transl: - forall fb f tf, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transf_function f = OK tf -> - Genv.find_funct_ptr tge fb = Some (Internal tf). -Proof. - intros. exploit function_ptr_translated; eauto. - intros (tf' & A & B). monadInv B. rewrite H0 in EQ. inv EQ. auto. -Qed. - -Inductive match_states: state -> state -> Prop := - | match_states_intro: - forall s1 s2, s1 = s2 -> match_states s1 s2. - -Lemma prog_main_preserved: - prog_main tprog = prog_main prog. -Proof (match_program_main TRANSL). - -Lemma prog_main_address_preserved: - (Genv.symbol_address (Genv.globalenv prog) (prog_main prog) Ptrofs.zero) = - (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero). -Proof. - unfold Genv.symbol_address. rewrite symbols_preserved. - rewrite prog_main_preserved. auto. -Qed. - -Lemma transf_initial_states: - forall st1, initial_state prog st1 -> - exists st2, initial_state tprog st2 /\ match_states st1 st2. -Proof. - intros. inv H. - econstructor; split. - - eapply initial_state_intro. - eapply (Genv.init_mem_transf_partial TRANSL); eauto. - - econstructor; eauto. subst ge0. subst rs0. rewrite prog_main_address_preserved. auto. -Qed. - -Lemma transf_final_states: - forall st1 st2 r, - match_states st1 st2 -> final_state st1 r -> final_state st2 r. -Proof. - intros. inv H0. inv H. econstructor; eauto. -Qed. - -Lemma tail_find_bblock: - forall lbb pos bb, - find_bblock pos lbb = Some bb -> - exists c, code_tail pos lbb (bb::c). -Proof. - induction lbb. - - intros. simpl in H. inv H. - - intros. simpl in H. - destruct (zlt pos 0); try (inv H; fail). - destruct (zeq pos 0). - + inv H. exists lbb. constructor; auto. - + apply IHlbb in H. destruct H as (c & TAIL). exists c. - enough (pos = pos - size a + size a) as ->. - apply code_tail_S; auto. - omega. -Qed. - -Lemma code_tail_head_app: - forall l pos c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + size_blocks l) (l++c1) c2. -Proof. - induction l. - - intros. simpl. rewrite Z.add_0_r. auto. - - intros. apply IHl in H. simpl. rewrite (Z.add_comm (size a)). rewrite Z.add_assoc. apply code_tail_S. assumption. -Qed. - -Lemma transf_blocks_verified: - forall c tc pos bb c', - transf_blocks c = OK tc -> - code_tail pos c (bb::c') -> - exists lbb, - verified_schedule bb = OK lbb - /\ exists tc', code_tail pos tc (lbb ++ tc'). -Proof. - induction c; intros. - - simpl in H. inv H. inv H0. - - inv H0. - + monadInv H. exists x0. - split; simpl; auto. eexists; eauto. econstructor; eauto. - + unfold transf_blocks in H. fold transf_blocks in H. monadInv H. - exploit IHc; eauto. - intros (lbb & TRANS & tc' & TAIL). -(* monadInv TRANS. *) - repeat eexists; eauto. - erewrite verified_schedule_size; eauto. - apply code_tail_head_app. - eauto. -Qed. - -Lemma transf_find_bblock: - forall ofs f bb tf, - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bb -> - transf_function f = OK tf -> - exists lbb, - verified_schedule bb = OK lbb - /\ exists c, code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c). -Proof. - intros. - monadInv H0. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); try (inv EQ0; fail). inv EQ0. - monadInv EQ. apply tail_find_bblock in H. destruct H as (c & TAIL). - eapply transf_blocks_verified; eauto. -Qed. - -Lemma symbol_address_preserved: - forall l ofs, Genv.symbol_address ge l ofs = Genv.symbol_address tge l ofs. -Proof. - intros. unfold Genv.symbol_address. repeat (rewrite symbols_preserved). reflexivity. -Qed. - -Lemma head_tail {A: Type}: - forall (l: list A) hd, hd::l = hd :: (tail (hd::l)). -Proof. - intros. simpl. auto. -Qed. - -Lemma verified_schedule_not_empty: - forall bb lbb, - verified_schedule bb = OK lbb -> lbb <> nil. -Proof. - intros. apply verified_schedule_size in H. - pose (size_positive bb). assert (size_blocks lbb > 0) by omega. clear H g. - destruct lbb; simpl in *; discriminate. -Qed. - -Lemma header_nil_label_pos_none: - forall lbb l p, - Forall (fun b => header b = nil) lbb -> label_pos l p lbb = None. -Proof. - induction lbb. - - intros. simpl. auto. - - intros. inv H. simpl. unfold is_label. rewrite H2. destruct (in_dec l nil). { inv i. } - auto. -Qed. - -Lemma verified_schedule_label: - forall bb tbb lbb l, - verified_schedule bb = OK (tbb :: lbb) -> - is_label l bb = is_label l tbb - /\ label_pos l 0 lbb = None. -Proof. - intros. exploit verified_schedule_header; eauto. - intros (HdrEq & HdrNil). - split. - - unfold is_label. rewrite HdrEq. reflexivity. - - apply header_nil_label_pos_none. assumption. -Qed. - -Lemma label_pos_app_none: - forall c c' l p p', - label_pos l p c = None -> - label_pos l (p' + size_blocks c) c' = label_pos l p' (c ++ c'). -Proof. - induction c. - - intros. simpl in *. rewrite Z.add_0_r. reflexivity. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLABEL. - + discriminate. - + eapply IHc in H. rewrite Z.add_assoc. eauto. -Qed. - -Remark label_pos_pvar_none_add: - forall tc l p p' k, - label_pos l (p+k) tc = None -> label_pos l (p'+k) tc = None. -Proof. - induction tc. - - intros. simpl. auto. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + discriminate. - + pose (IHtc l p p' (k + size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar_none: - forall tc l p p', - label_pos l p tc = None -> label_pos l p' tc = None. -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_none_add; eauto. -Qed. - -Remark label_pos_pvar_some_add_add: - forall tc l p p' k k', - label_pos l (p+k') tc = Some (p+k) -> label_pos l (p'+k') tc = Some (p'+k). -Proof. - induction tc. - - intros. simpl in H. discriminate. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + inv H. assert (k = k') by omega. subst. reflexivity. - + pose (IHtc l p p' k (k' + size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar_some_add: - forall tc l p p' k, - label_pos l p tc = Some (p+k) -> label_pos l p' tc = Some (p'+k). -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_some_add_add; eauto. -Qed. - -Remark label_pos_pvar_add: - forall c tc l p p' k, - label_pos l (p+k) c = label_pos l p tc -> - label_pos l (p'+k) c = label_pos l p' tc. -Proof. - induction c. - - intros. simpl in *. - exploit label_pos_pvar_none; eauto. - - intros. simpl in *. destruct (is_label _ _) eqn:ISLBL. - + exploit label_pos_pvar_some_add; eauto. - + pose (IHc tc l p p' (k+size a)). repeat (rewrite Z.add_assoc in e). auto. -Qed. - -Lemma label_pos_pvar: - forall c tc l p p', - label_pos l p c = label_pos l p tc -> - label_pos l p' c = label_pos l p' tc. -Proof. - intros. rewrite (Zplus_0_r_reverse p') at 1. rewrite (Zplus_0_r_reverse p) in H at 1. - eapply label_pos_pvar_add; eauto. -Qed. - -Lemma label_pos_head_app: - forall c bb lbb l tc p, - verified_schedule bb = OK lbb -> - label_pos l p c = label_pos l p tc -> - label_pos l p (bb :: c) = label_pos l p (lbb ++ tc). -Proof. - intros. simpl. destruct lbb as [|tbb lbb]. - - apply verified_schedule_not_empty in H. contradiction. - - simpl. exploit verified_schedule_label; eauto. intros (ISLBL & LBLPOS). - rewrite ISLBL. - destruct (is_label l tbb) eqn:ISLBL'; simpl; auto. - eapply label_pos_pvar in H0. erewrite H0. - erewrite verified_schedule_size; eauto. simpl size_blocks. rewrite Z.add_assoc. - erewrite label_pos_app_none; eauto. -Qed. - -Lemma label_pos_preserved: - forall c tc l, - transf_blocks c = OK tc -> label_pos l 0 c = label_pos l 0 tc. -Proof. - induction c. - - intros. simpl in *. inv H. reflexivity. - - intros. unfold transf_blocks in H; fold transf_blocks in H. monadInv H. eapply IHc in EQ. - eapply label_pos_head_app; eauto. -Qed. - -Lemma label_pos_preserved_blocks: - forall l f tf, - transf_function f = OK tf -> - label_pos l 0 (fn_blocks f) = label_pos l 0 (fn_blocks tf). -Proof. - intros. monadInv H. monadInv EQ. - destruct (zlt Ptrofs.max_unsigned _); try discriminate. - monadInv EQ0. simpl. eapply label_pos_preserved; eauto. -Qed. - -Lemma transf_exec_control: - forall f tf ex rs m, - transf_function f = OK tf -> - exec_control ge f ex rs m = exec_control tge tf ex rs m. -Proof. - intros. destruct ex; simpl; auto. - assert (ge = Genv.globalenv prog). auto. - assert (tge = Genv.globalenv tprog). auto. - pose symbol_address_preserved. - exploreInst; simpl; auto; try congruence; - unfold par_goto_label; unfold par_eval_branch; unfold par_goto_label; erewrite label_pos_preserved_blocks; eauto. -Qed. - -Lemma transf_exec_basic_instr: - forall i rs m, exec_basic_instr ge i rs m = exec_basic_instr tge i rs m. -Proof. - intros. pose symbol_address_preserved. - unfold exec_basic_instr. unfold bstep. exploreInst; simpl; auto; try congruence. - unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence. -Qed. - -Lemma transf_exec_body: - forall bdy rs m, exec_body ge bdy rs m = exec_body tge bdy rs m. -Proof. - induction bdy; intros. - - simpl. reflexivity. - - simpl. rewrite transf_exec_basic_instr. - destruct (exec_basic_instr _ _ _); auto. -Qed. - -Lemma transf_exec_bblock: - forall f tf bb rs m, - transf_function f = OK tf -> - exec_bblock ge f bb rs m = exec_bblock tge tf bb rs m. -Proof. - intros. unfold exec_bblock. rewrite transf_exec_body. destruct (exec_body _ _ _ _); auto. - eapply transf_exec_control; eauto. -Qed. - -Lemma transf_step_simu: - forall tf b lbb ofs c tbb rs m rs' m', - Genv.find_funct_ptr tge b = Some (Internal tf) -> - size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned -> - rs PC = Vptr b ofs -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (lbb ++ c) -> - concat_all lbb = OK tbb -> - exec_bblock tge tf tbb rs m = Next rs' m' -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - induction lbb. - - intros until m'. simpl. intros. discriminate. - - intros until m'. intros GFIND SIZE PCeq TAIL CONC EXEB. - destruct lbb. - + simpl in *. clear IHlbb. inv CONC. eapply plus_one. econstructor; eauto. eapply find_bblock_tail; eauto. - + exploit concat_all_exec_bblock; eauto; try discriminate. - intros (tbb0 & rs0 & m0 & CONC0 & EXEB0 & PCeq' & EXEB1). - eapply plus_left. - econstructor. - 3: eapply find_bblock_tail. rewrite <- app_comm_cons in TAIL. 3: eauto. - all: eauto. - eapply plus_star. eapply IHlbb; eauto. rewrite PCeq in PCeq'. simpl in PCeq'. all: eauto. - eapply code_tail_next_int; eauto. -Qed. - -Theorem transf_step_correct: - forall s1 t s2, step ge s1 t s2 -> - forall s1' (MS: match_states s1 s1'), - (exists s2', plus step tge s1' t s2' /\ match_states s2 s2'). -Proof. - induction 1; intros; inv MS. - - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. - exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). - exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). inv CONC. rename H3 into CONC. - assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned). - eapply transf_function_no_overflow; eauto. - - erewrite transf_exec_bblock in H2; eauto. - unfold bblock_simu in BBEQ. rewrite BBEQ in H2; try congruence. - exists (State rs' m'). split; try (constructor; auto). - eapply transf_step_simu; eauto. - - - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. - exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL). - exploit verified_schedule_builtin_idem; eauto. intros. subst lbb. - - remember (State (nextblock _ _) _) as s'. exists s'. - split; try constructor; auto. - eapply plus_one. subst s'. - eapply exec_step_builtin. - 3: eapply find_bblock_tail. simpl in TAIL. 3: eauto. - all: eauto. - eapply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. - - - exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF. - remember (State _ m') as s'. exists s'. split; try constructor; auto. - subst s'. eapply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved; eauto. apply senv_preserved. -Qed. - -Theorem transf_program_correct_Asmblock: - forward_simulation (Asmblock.semantics prog) (Asmblock.semantics tprog). -Proof. - eapply forward_simulation_plus. - - apply senv_preserved. - - apply transf_initial_states. - - apply transf_final_states. - - apply transf_step_correct. -Qed. - -End PRESERVATION_ASMBLOCK. - -Require Import Asmvliw. - -Lemma verified_par_checks_alls_bundles lb x: forall bundle, - verify_par lb = OK x -> - List.In bundle lb -> verify_par_bblock bundle = OK tt. -Proof. - induction lb; simpl; try tauto. - intros bundle H; monadInv H. - destruct 1; subst; eauto. - destruct x0; auto. -Qed. - -Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle: - verified_schedule_nob bb = OK lb -> - List.In bundle lb -> verify_par_bblock bundle = OK tt. -Proof. - unfold verified_schedule_nob. intros H; - monadInv H. destruct x4. - intros; eapply verified_par_checks_alls_bundles; eauto. -Qed. - -Lemma verify_par_bblock_PExpand bb i: - exit bb = Some (PExpand i) -> verify_par_bblock bb = OK tt. -Proof. - destruct bb as [h bdy ext H]; simpl. - intros; subst. destruct i. - generalize H. - rewrite <- wf_bblock_refl in H. - destruct H as [H H0]. - unfold builtin_alone in H0. erewrite H0; eauto. -Qed. - -Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core. - -Lemma verified_schedule_checks_alls_bundles bb lb bundle: - verified_schedule bb = OK lb -> - List.In bundle lb -> verify_par_bblock bundle = OK tt. -Proof. - unfold verified_schedule. remember (exit bb) as exb. - destruct exb as [c|]; eauto. - destruct c as [i|]; eauto. - destruct i; intros H. inversion_clear H; simpl. - intuition subst. - intros; eapply verify_par_bblock_PExpand; eauto. -Qed. - -Lemma transf_blocks_checks_all_bundles lbb: forall lb bundle, - transf_blocks lbb = OK lb -> - List.In bundle lb -> verify_par_bblock bundle = OK tt. -Proof. - induction lbb; simpl. - - intros lb bundle H; inversion_clear H. simpl; try tauto. - - intros lb bundle H0. - monadInv H0. - rewrite in_app. destruct 1; eauto. - eapply verified_schedule_checks_alls_bundles; eauto. -Qed. - -Lemma find_bblock_Some_in lb: - forall ofs b, find_bblock ofs lb = Some b -> List.In b lb. -Proof. - induction lb; simpl; try congruence. - intros ofs b. - destruct (zlt ofs 0); try congruence. - destruct (zeq ofs 0); eauto. - intros X; inversion X; eauto. -Qed. - -Section PRESERVATION_ASMVLIW. - -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma all_bundles_are_checked b ofs f bundle: - Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> - find_bblock ofs (fn_blocks f) = Some bundle -> - verify_par_bblock bundle = OK tt. -Proof. - unfold match_prog, match_program in TRANSL. - unfold Genv.find_funct_ptr; simpl; intros X. - destruct (Genv.find_def_match_2 TRANSL b) as [|f0 y H]; try congruence. - destruct y as [tf0|]; try congruence. - inversion X as [H1]. subst. clear X. - remember (@Gfun fundef unit (Internal f)) as f2. - destruct H as [ctx' f1 f2 H0|]; try congruence. - inversion Heqf2 as [H2]. subst; clear Heqf2. - unfold transf_fundef, transf_partial_fundef in H. - destruct f1 as [f1|f1]; try congruence. - unfold transf_function, transl_function in H. - monadInv H. monadInv EQ. - destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks _))); simpl in *|-; try congruence. - injection EQ1; intros; subst. - monadInv EQ0. simpl in * |-. - intros; exploit transf_blocks_checks_all_bundles; eauto. - intros; eapply find_bblock_Some_in; eauto. -Qed. - -Lemma checked_bundles_are_parexec_equiv f bundle rs rs' m m': - exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> - verify_par_bblock bundle = OK tt -> - det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. -Proof. - intros. unfold verify_par_bblock in H0. destruct (Asmblockdeps.bblock_para_check _) eqn:BPC; try discriminate. clear H0. - simpl in H. - eapply Asmblockdeps.bblock_para_check_correct; eauto. -Qed. - -Lemma seqexec_parexec_equiv b ofs f bundle rs rs' m m': - Genv.find_funct_ptr (globalenv (Asmblock.semantics tprog)) b = Some (Internal f) -> - find_bblock (Ptrofs.unsigned ofs) (fn_blocks f) = Some bundle -> - exec_bblock (globalenv (Asmblock.semantics tprog)) f bundle rs m = Next rs' m' -> - det_parexec (globalenv (semantics tprog)) f bundle rs m rs' m'. -Proof. - intros; eapply checked_bundles_are_parexec_equiv; eauto. - eapply all_bundles_are_checked; eauto. -Qed. - -Theorem transf_program_correct_Asmvliw: - forward_simulation (Asmblock.semantics tprog) (Asmvliw.semantics tprog). -Proof. - eapply forward_simulation_step with (match_states:=fun (s1:Asmvliw.state) s2 => s1=s2); eauto. - - intros; subst; auto. - - intros s1 t s1' H s2 H0; subst; inversion H; clear H; subst; eexists; split; eauto. - + eapply exec_step_internal; eauto. - intros; eapply seqexec_parexec_equiv; eauto. - + eapply exec_step_builtin; eauto. - + eapply exec_step_external; eauto. -Qed. - -End PRESERVATION_ASMVLIW. - -Section PRESERVATION. - -Variables prog tprog: program. -Hypothesis TRANSL: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Theorem transf_program_correct: - forward_simulation (Asmblock.semantics prog) (Asmvliw.semantics tprog). -Proof. - eapply compose_forward_simulations. - eapply transf_program_correct_Asmblock; eauto. - eapply transf_program_correct_Asmvliw; eauto. -Qed. - -End PRESERVATION. diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml deleted file mode 100644 index da7d6c32..00000000 --- a/mppa_k1c/PrintOp.ml +++ /dev/null @@ -1,229 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Pretty-printing of operators, conditions, addressing modes *) - -open Printf -open Camlcoq -open Integers -open Op -open ExtValues - -let comparison_name = function - | Ceq -> "==" - | Cne -> "!=" - | Clt -> "<" - | Cle -> "<=" - | Cgt -> ">" - | Cge -> ">=" - -let print_condition reg pp = function - | (Ccomp c, [r1;r2]) -> - fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2 - | (Ccompu c, [r1;r2]) -> - fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2 - | (Ccompimm(c, n), [r1]) -> - fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n) - | (Ccompuimm(c, n), [r1]) -> - fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n) - | (Ccompf c, [r1;r2]) -> - fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2 - | (Ccompl c, [r1;r2]) -> - fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2 - | (Ccomplu c, [r1;r2]) -> - fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2 - | (Ccomplimm(c, n), [r1]) -> - fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n) - | (Ccompluimm(c, n), [r1]) -> - fprintf pp "%a %slu %Lu" reg r1 (comparison_name c) (camlint64_of_coqint n) - | (Cnotcompf c, [r1;r2]) -> - fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2 - | (Ccompfs c, [r1;r2]) -> - fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2 - | (Cnotcompfs c, [r1;r2]) -> - fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2 - | _ -> - fprintf pp "" - -let print_condition0 reg pp cond0 rc = - match cond0 with - | Ccomp0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) - | Ccompu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) - | Ccompl0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c) - | Ccomplu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c) - -let int_of_s14 = function - | SHIFT1 -> 1 - | SHIFT2 -> 2 - | SHIFT3 -> 3 - | SHIFT4 -> 4 - -let print_operation reg pp op = match op with - | Omove, [r1] -> reg pp r1 - | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n) - | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n) - | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n) - | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n) - | Oaddrsymbol(id, ofs), [] -> - fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) - | Oaddrstack ofs, [] -> - fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) - | Ocast8signed, [r1] -> fprintf pp "int8signed(%a)" reg r1 - | Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1 - | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 - | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n) - | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2 - | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm) - | Oneg, [r1] -> fprintf pp "-(%a)" reg r1 - | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2 - | Orevsubimm(imm), [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1 - | Orevsubx(s14), [r1; r2] -> fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14) - | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14) - | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2 - | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm) - | Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2 - | Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2 - | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2 - | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2 - | Omod, [r1;r2] -> fprintf pp "%a %%s %a" reg r1 reg r2 - | Omodu, [r1;r2] -> fprintf pp "%a %%u %a" reg r1 reg r2 - | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2 - | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n) - | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2 - | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n) - | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2 - | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n) - | Onxor, [r1;r2] -> fprintf pp "~(%a ^ %a)" reg r1 reg r2 - | Onxorimm n, [r1] -> fprintf pp "~(%a ^ %ld)" reg r1 (camlint_of_coqint n) - | Onot, [r1] -> fprintf pp "~%a" reg r1 - | Oandn, [r1; r2] -> fprintf pp "(~%a) & %a" reg r1 reg r2 - | Oandnimm n, [r1] -> fprintf pp "(~%a) & %ld" reg r1 (camlint_of_coqint n) - | Oorn, [r1;r2] -> fprintf pp "(~%a) | %a" reg r1 reg r2 - | Oornimm n, [r1] -> fprintf pp "(~%a) | %ld" reg r1 (camlint_of_coqint n) - | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2 - | Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n) - | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2 - | Oshrimm n, [r1] -> fprintf pp "%a >>s %ld" reg r1 (camlint_of_coqint n) - | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2 - | Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n) - | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n) - | Ororimm n, [r1] -> fprintf pp "(%a ror %ld)" reg r1 (camlint_of_coqint n) - | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3 - | Omaddimm imm, [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm) - | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3 - - | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2 - | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1 - | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1 - | Ocast32signed, [r1] -> fprintf pp "long32signed(%a)" reg r1 - | Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1 - | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2 - | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n) - | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a < fprintf pp "(%a < fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1 - | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a < fprintf pp "%Ld -l (%a < fprintf pp "-l (%a)" reg r1 - | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2 - | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2 - | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm) - | Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2 - | Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2 - | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2 - | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2 - | Omodl, [r1;r2] -> fprintf pp "%a %%ls %a" reg r1 reg r2 - | Omodlu, [r1;r2] -> fprintf pp "%a %%lu %a" reg r1 reg r2 - | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2 - | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n) - | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2 - | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n) - | Onorl, [r1; r2] -> fprintf pp "~(%a |l %a)" reg r1 reg r2 - | Onorlimm n, [r1] -> fprintf pp "~(%a |l %Ld)" reg r1 (camlint64_of_coqint n) - | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2 - | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n) - | Onxorl, [r1;r2] -> fprintf pp "~(%a ^l %a)" reg r1 reg r2 - | Onxorlimm n, [r1] -> fprintf pp "~(%a ^l %Ld)" reg r1 (camlint64_of_coqint n) - | Onotl, [r1] -> fprintf pp "~%a" reg r1 - | Oandnl, [r1;r2] -> fprintf pp "(~%a) &l %a" reg r1 reg r2 - | Oandnlimm n, [r1] -> fprintf pp "(~%a) &l %Ld" reg r1 (camlint64_of_coqint n) - | Oornl, [r1;r2] -> fprintf pp "(~%a) |l %a" reg r1 reg r2 - | Oornlimm n, [r1;r2] -> fprintf pp "(~%a) |l %Ld" reg r1 (camlint64_of_coqint n) - | Oshll, [r1;r2] -> fprintf pp "%a < fprintf pp "%a < fprintf pp "%a >>ls %a" reg r1 reg r2 - | Oshrlimm n, [r1] -> fprintf pp "%a >>ls %ld" reg r1 (camlint_of_coqint n) - | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2 - | Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n) - | Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n) - | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3 - | Omaddlimm imm, [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm) - | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3 - - | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1 - | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1 - | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2 - | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2 - | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2 - | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2 - | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1 - | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1 - | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2 - | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2 - | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2 - | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2 - | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1 - | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1 - | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1 - | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1 - | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1 - | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1 - | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1 - | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1 - | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1 - | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1 - | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1 - | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1 - | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1 - | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1 - | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1 - | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1 - | Ocmp c, args -> print_condition reg pp (c, args) - - | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 - | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 - | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 - | Oextfsl(stop, start), [r1] -> fprintf pp "extfsl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 - | Oinsf(stop, start), [r1; r2] -> fprintf pp "insf(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 - | Oinsfl(stop, start), [r1; r2] -> fprintf pp "insfl(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2 - | Osel(cond0, ty), [r1; r2; rc] -> - print_condition0 reg pp cond0 rc; - fprintf pp " ? %a : %a" reg r1 reg r2 - | Oselimm(cond0, imm), [r1; rc] -> - print_condition0 reg pp cond0 rc; - fprintf pp " ? %a : %ld" reg r1 (camlint_of_coqint imm) - | Osellimm(cond0, imm), [r1; rc] -> - print_condition0 reg pp cond0 rc; - fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm) - | _, _ -> fprintf pp "" - -let print_addressing reg pp = function - | Aindexed2XS scale, [r1;r2] -> fprintf pp "%a + (%a << %ld)" reg r1 reg r2 (camlint_of_coqint scale) - | Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2 - | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n) - | Aglobal(id, ofs), [] -> - fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs) - | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs) - | _ -> fprintf pp "" diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp deleted file mode 100644 index b3638eca..00000000 --- a/mppa_k1c/SelectLong.vp +++ /dev/null @@ -1,463 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Instruction selection for 64-bit integer operations *) - -Require Import Coqlib. -Require Import Compopts. -Require Import AST Integers Floats. -Require Import Op CminorSel. -Require Import OpHelpers. -Require Import SelectOp SplitLong. -Require Import ExtValues. -Require Import DecBoolOps. - -Local Open Scope cminorsel_scope. -Local Open Scope string_scope. - -Section SELECT. - -Context {hf: helper_functions}. - -Definition longconst (n: int64) : expr := - if Archi.splitlong then SplitLong.longconst n else Eop (Olongconst n) Enil. - -Definition is_longconst (e: expr) := - if Archi.splitlong then SplitLong.is_longconst e else - match e with - | Eop (Olongconst n) Enil => Some n - | _ => None - end. - -Definition intoflong (e: expr) := - if Archi.splitlong then SplitLong.intoflong e else - match is_longconst e with - | Some n => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil - | None => Eop Olowlong (e ::: Enil) - end. - -Definition longofint (e: expr) := - if Archi.splitlong then SplitLong.longofint e else - match is_intconst e with - | Some n => longconst (Int64.repr (Int.signed n)) - | None => Eop Ocast32signed (e ::: Enil) - end. - -Definition longofintu (e: expr) := - if Archi.splitlong then SplitLong.longofintu e else - match is_intconst e with - | Some n => longconst (Int64.repr (Int.unsigned n)) - | None => Eop Ocast32unsigned (e ::: Enil) - end. - -(** ** Integer addition and pointer addition *) - -Definition addlimm_shllimm sh k2 e1 := - if Compopts.optim_addx tt - then - match shift1_4_of_z (Int.unsigned sh) with - | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil) - | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil) - end - else Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil). - -Nondetfunction addlimm (n: int64) (e: expr) := - if Int64.eq n Int64.zero then e else - match e with - | Eop (Olongconst m) Enil => longconst (Int64.add n m) - | Eop (Oaddrsymbol s m) Enil => - (if Compopts.optim_globaladdroffset tt - then Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil - else Eop (Oaddlimm n) (e ::: Enil)) - | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil - | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil) - | Eop (Oaddxlimm sh m) (t ::: Enil) => Eop (Oaddxlimm sh (Int64.add n m)) (t ::: Enil) - | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1 - | _ => Eop (Oaddlimm n) (e ::: Enil) - end. - -Definition addl_shllimm n e1 e2 := - if Compopts.optim_addx tt - then - match shift1_4_of_z (Int.unsigned n) with - | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil) - | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil) - end - else Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil). - -Nondetfunction addl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.addl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => addlimm n2 t1 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil)) - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil) - | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) => - Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil) - | Eop (Oaddlimm n1) (t1:::Enil), t2 => - addlimm n1 (Eop Oaddl (t1:::t2:::Enil)) - | t1, Eop (Oaddlimm n2) (t2:::Enil) => - addlimm n2 (Eop Oaddl (t1:::t2:::Enil)) - | t1, (Eop Omull (t2:::t3:::Enil)) => - Eop Omaddl (t1:::t2:::t3:::Enil) - | (Eop Omull (t2:::t3:::Enil)), t1 => - Eop Omaddl (t1:::t2:::t3:::Enil) - | t1, (Eop (Omullimm n) (t2:::Enil)) => - Eop (Omaddlimm n) (t1:::t2:::Enil) - | (Eop (Omullimm n) (t2:::Enil)), t1 => - Eop (Omaddlimm n) (t1:::t2:::Enil) - | (Eop (Oshllimm n) (t1:::Enil)), t2 => - addl_shllimm n t1 t2 - | t2, (Eop (Oshllimm n) (t1:::Enil)) => - addl_shllimm n t1 t2 - | _, _ => Eop Oaddl (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -Nondetfunction subl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.subl e1 e2 else - match e1, e2 with - | t1, Eop (Olongconst n2) Enil => - addlimm (Int64.neg n2) t1 - | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil)) - | Eop (Oaddlimm n1) (t1:::Enil), t2 => - addlimm n1 (Eop Osubl (t1:::t2:::Enil)) - | t1, Eop (Oaddlimm n2) (t2:::Enil) => - addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil)) - | t1, (Eop Omull (t2:::t3:::Enil)) => - Eop Omsubl (t1:::t2:::t3:::Enil) - | t1, (Eop (Omullimm n) (t2:::Enil)) => - Eop (Omaddlimm (Int64.neg n)) (t1:::t2:::Enil) - | _, _ => Eop Osubl (e1:::e2:::Enil) - end. - -Definition negl (e: expr) := - if Archi.splitlong then SplitLong.negl e else - match is_longconst e with - | Some n => longconst (Int64.neg n) - | None => Eop Onegl (e ::: Enil) - end. - -(** ** Immediate shifts *) - -Nondetfunction shllimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shllimm e1 n else - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int64.iwordsize') then - Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shl' n1 n) - | Eop (Oshllimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshllimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshllimm n) (e1:::Enil) - | _ => - Eop (Oshllimm n) (e1:::Enil) - end. - -Nondetfunction shrluimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrluimm e1 n else - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int64.iwordsize') then - Eop Oshrlu (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shru' n1 n) - | Eop (Oshrluimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshrluimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrluimm n) (e1:::Enil) - | Eop (Oshllimm n1) (t1:::Enil) => - let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in - let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in - if is_bitfieldl stop start - then Eop (Oextfzl stop start) (t1:::Enil) - else Eop (Oshrluimm n) (e1:::Enil) - | _ => - Eop (Oshrluimm n) (e1:::Enil) - end. - -Nondetfunction shrlimm (e1: expr) (n: int) := - if Archi.splitlong then SplitLong.shrlimm e1 n else - if Int.eq n Int.zero then e1 else - if negb (Int.ltu n Int64.iwordsize') then - Eop Oshrl (e1:::Eop (Ointconst n) Enil:::Enil) - else - match e1 with - | Eop (Olongconst n1) Enil => - longconst (Int64.shr' n1 n) - | Eop (Oshrlimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int64.iwordsize' - then Eop (Oshrlimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrlimm n) (e1:::Enil) - | Eop (Oshllimm n1) (t1:::Enil) => - let stop := Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one) in - let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int64.zwordsize in - if is_bitfieldl stop start - then Eop (Oextfsl stop start) (t1:::Enil) - else Eop (Oshrlimm n) (e1:::Enil) - | _ => - Eop (Oshrlimm n) (e1:::Enil) - end. - -(** ** General shifts *) - -Definition shll (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shll e1 e2 else - match is_intconst e2 with - | Some n2 => shllimm e1 n2 - | None => Eop Oshll (e1:::e2:::Enil) - end. - -Definition shrl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shrl e1 e2 else - match is_intconst e2 with - | Some n2 => shrlimm e1 n2 - | None => Eop Oshrl (e1:::e2:::Enil) - end. - -Definition shrlu (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.shrlu e1 e2 else - match is_intconst e2 with - | Some n2 => shrluimm e1 n2 - | _ => Eop Oshrlu (e1:::e2:::Enil) - end. - -(** ** Integer multiply *) - -Definition mullimm_base (n1: int64) (e2: expr) := - match Int64.one_bits' n1 with - | i :: nil => - shllimm e2 i - | i :: j :: nil => - Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j)) - | _ => - Eop (Omullimm n1) (e2 ::: Enil) - end. - -Nondetfunction mullimm (n1: int64) (e2: expr) := - if Archi.splitlong then SplitLong.mullimm n1 e2 - else if Int64.eq n1 Int64.zero then longconst Int64.zero - else if Int64.eq n1 Int64.one then e2 - else match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.mul n1 n2) - | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2) - | _ => mullimm_base n1 e2 - end. - -Nondetfunction mull (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.mull e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2 - | t1, Eop (Olongconst n2) Enil => mullimm n2 t1 - | _, _ => Eop Omull (e1:::e2:::Enil) - end. - -Definition mullhu (e1: expr) (n2: int64) := - if Archi.splitlong then SplitLong.mullhu e1 n2 else - Eop Omullhu (e1 ::: longconst n2 ::: Enil). - -Definition mullhs (e1: expr) (n2: int64) := - if Archi.splitlong then SplitLong.mullhs e1 n2 else - Eop Omullhs (e1 ::: longconst n2 ::: Enil). - -(** ** Bitwise and, or, xor *) - -Nondetfunction andlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then longconst Int64.zero else - if Int64.eq n1 Int64.mone then e2 else - match e2 with - | Eop (Olongconst n2) Enil => - longconst (Int64.and n1 n2) - | Eop (Oandlimm n2) (t2:::Enil) => - Eop (Oandlimm (Int64.and n1 n2)) (t2:::Enil) - | Eop Onotl (t2:::Enil) => Eop (Oandnlimm n1) (t2:::Enil) - | _ => - Eop (Oandlimm n1) (e2:::Enil) - end. - -Nondetfunction andl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.andl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => andlimm n2 t1 - | (Eop Onotl (t1:::Enil)), t2 => Eop Oandnl (t1:::t2:::Enil) - | t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil) - | _, _ => Eop Oandl (e1:::e2:::Enil) - end. - -Nondetfunction orlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else - if Int64.eq n1 Int64.mone then longconst Int64.mone else - match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.or n1 n2) - | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil) - | Eop Onotl (t2:::Enil) => Eop (Oornlimm n1) (t2:::Enil) - | _ => Eop (Oorlimm n1) (e2:::Enil) - end. - -Nondetfunction orl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.orl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => orlimm n2 t1 - | (Eop Onotl (t1:::Enil)), t2 => Eop Oornl (t1:::t2:::Enil) - | t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil) - | (Eop (Oandlimm nmask) (prev:::Enil)), - (Eop (Oandlimm mask) - ((Eop (Oshllimm start) (fld:::Enil)):::Enil)) => - let zstart := Int.unsigned start in - let zstop := int64_highest_bit mask in - if is_bitfieldl zstop zstart - then - let mask' := Int64.repr (zbitfield_mask zstop zstart) in - if and_dec (Int64.eq_dec mask mask') - (Int64.eq_dec nmask (Int64.not mask')) - then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) - else Eop Oorl (e1:::e2:::Enil) - else Eop Oorl (e1:::e2:::Enil) - | (Eop (Oandlimm nmask) (prev:::Enil)), - (Eop (Oandlimm mask) (fld:::Enil)) => - let zstart := 0 in - let zstop := int64_highest_bit mask in - if is_bitfieldl zstop zstart - then - let mask' := Int64.repr (zbitfield_mask zstop zstart) in - if and_dec (Int64.eq_dec mask mask') - (Int64.eq_dec nmask (Int64.not mask')) - then Eop (Oinsfl zstop zstart) (prev:::fld:::Enil) - else Eop Oorl (e1:::e2:::Enil) - else Eop Oorl (e1:::e2:::Enil) - | _, _ => Eop Oorl (e1:::e2:::Enil) - end. - -Nondetfunction xorlimm (n1: int64) (e2: expr) := - if Int64.eq n1 Int64.zero then e2 else - if Int64.eq n1 Int64.mone - then Eop Onotl (e2:::Enil) - else - match e2 with - | Eop (Olongconst n2) Enil => longconst (Int64.xor n1 n2) - | Eop (Oxorlimm n2) (t2:::Enil) => - let n := Int64.xor n1 n2 in - if Int64.eq n Int64.zero then t2 else Eop (Oxorlimm n) (t2:::Enil) - | _ => Eop (Oxorlimm n1) (e2:::Enil) - end. - -Nondetfunction xorl (e1: expr) (e2: expr) := - if Archi.splitlong then SplitLong.xorl e1 e2 else - match e1, e2 with - | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2 - | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1 - | _, _ => Eop Oxorl (e1:::e2:::Enil) - end. - -(** ** Integer logical negation *) - -Nondetfunction notl (e: expr) := - match e with - | Eop Oandl (e1:::e2:::Enil) => Eop Onandl (e1:::e2:::Enil) - | Eop (Oandlimm n) (e1:::Enil) => Eop (Onandlimm n) (e1:::Enil) - | Eop Oorl (e1:::e2:::Enil) => Eop Onorl (e1:::e2:::Enil) - | Eop (Oorlimm n) (e1:::Enil) => Eop (Onorlimm n) (e1:::Enil) - | Eop Oxorl (e1:::e2:::Enil) => Eop Onxorl (e1:::e2:::Enil) - | Eop (Oxorlimm n) (e1:::Enil) => Eop (Onxorlimm n) (e1:::Enil) - | Eop Onandl (e1:::e2:::Enil) => Eop Oandl (e1:::e2:::Enil) - | Eop (Onandlimm n) (e1:::Enil) => Eop (Oandlimm n) (e1:::Enil) - | Eop Onorl (e1:::e2:::Enil) => Eop Oorl (e1:::e2:::Enil) - | Eop (Onorlimm n) (e1:::Enil) => Eop (Oorlimm n) (e1:::Enil) - | Eop Onxorl (e1:::e2:::Enil) => Eop Oxorl (e1:::e2:::Enil) - | Eop (Onxorlimm n) (e1:::Enil) => Eop (Oxorlimm n) (e1:::Enil) - | Eop Oandnl (e1:::e2:::Enil) => Eop Oornl (e2:::e1:::Enil) - | Eop (Oandnlimm n) (e1:::Enil) => Eop (Oorlimm (Int64.not n)) (e1:::Enil) - | Eop Oornl (e1:::e2:::Enil) => Eop Oandnl (e2:::e1:::Enil) - | Eop (Oornlimm n) (e1:::Enil) => Eop (Oandlimm (Int64.not n)) (e1:::Enil) - | Eop Onotl (e1:::Enil) => e1 - | Eop (Olongconst k) Enil => Eop (Olongconst (Int64.not k)) Enil - | _ => Eop Onotl (e:::Enil) - end. -(* old: if Archi.splitlong then SplitLong.notl e else xorlimm Int64.mone e. *) - -(** ** Integer division and modulus *) - -Definition divlu_base (e1: expr) (e2: expr) := SplitLong.divlu_base e1 e2. -Definition modlu_base (e1: expr) (e2: expr) := SplitLong.modlu_base e1 e2. -Definition divls_base (e1: expr) (e2: expr) := SplitLong.divls_base e1 e2. -Definition modls_base (e1: expr) (e2: expr) := SplitLong.modls_base e1 e2. - -Definition shrxlimm (e: expr) (n: int) := - if Archi.splitlong then SplitLong.shrxlimm e n else - if Int.eq n Int.zero then e else Eop (Oshrxlimm n) (e ::: Enil). - -(** ** Comparisons *) - -Definition cmplu (c: comparison) (e1 e2: expr) := - if Archi.splitlong then SplitLong.cmplu c e1 e2 else - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => - Eop (Ointconst (if Int64.cmpu c n1 n2 then Int.one else Int.zero)) Enil - | Some n1, None => Eop (Ocmp (Ccompluimm (swap_comparison c) n1)) (e2:::Enil) - | None, Some n2 => Eop (Ocmp (Ccompluimm c n2)) (e1:::Enil) - | None, None => Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil) - end. - -Definition cmpl (c: comparison) (e1 e2: expr) := - if Archi.splitlong then SplitLong.cmpl c e1 e2 else - match is_longconst e1, is_longconst e2 with - | Some n1, Some n2 => - Eop (Ointconst (if Int64.cmp c n1 n2 then Int.one else Int.zero)) Enil - | Some n1, None => Eop (Ocmp (Ccomplimm (swap_comparison c) n1)) (e2:::Enil) - | None, Some n2 => Eop (Ocmp (Ccomplimm c n2)) (e1:::Enil) - | None, None => Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil) - end. - -(** ** Floating-point conversions *) - -Definition longoffloat (e: expr) := - if Archi.splitlong then SplitLong.longoffloat e else - Eop Olongoffloat (e:::Enil). - -Definition longuoffloat (e: expr) := - if Archi.splitlong then SplitLong.longuoffloat e else - Eop Olonguoffloat (e:::Enil). - -Definition floatoflong (e: expr) := - if Archi.splitlong then SplitLong.floatoflong e else - Eop Ofloatoflong (e:::Enil). - -Definition floatoflongu (e: expr) := - if Archi.splitlong then SplitLong.floatoflongu e else - Eop Ofloatoflongu (e:::Enil). - -Definition longofsingle (e: expr) := longoffloat (floatofsingle e). - -Definition longuofsingle (e: expr) := longuoffloat (floatofsingle e). - -Definition singleoflong (e: expr) := SplitLong.singleoflong e. - -Definition singleoflongu (e: expr) := SplitLong.singleoflongu e. - -End SELECT. - -(* Local Variables: *) -(* mode: coq *) -(* End: *) diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v deleted file mode 100644 index fb38bbce..00000000 --- a/mppa_k1c/SelectLongproof.v +++ /dev/null @@ -1,950 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Correctness of instruction selection for 64-bit integer operations *) - -Require Import String Coqlib Maps Integers Floats Errors. -Require Archi. -Require Import AST Values ExtValues Memory Globalenvs Events. -Require Import Cminor Op CminorSel. -Require Import OpHelpers OpHelpersproof. -Require Import SelectOp SelectOpproof SplitLong SplitLongproof. -Require Import SelectLong. -Require Import DecBoolOps. - -Local Open Scope cminorsel_scope. -Local Open Scope string_scope. - -(** * Correctness of the instruction selection functions for 64-bit operators *) - -Section CMCONSTR. - -Variable prog: program. -Variable hf: helper_functions. -Hypothesis HELPERS: helper_functions_declared prog hf. -Let ge := Genv.globalenv prog. -Variable sp: val. -Variable e: env. -Variable m: mem. - -Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := - forall le a x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. - -Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := - forall le a x b y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. - -Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop := - forall le a x y, - eval_expr ge sp e m le a x -> - sem x = Some y -> - exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v. - -Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop := - forall le a x b y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - sem x y = Some z -> - exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v. - -Theorem eval_longconst: - forall le n, eval_expr ge sp e m le (longconst n) (Vlong n). -Proof. - unfold longconst; intros; destruct Archi.splitlong. - apply SplitLongproof.eval_longconst. - EvalOp. -Qed. - -Lemma is_longconst_sound: - forall v a n le, - is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n. -Proof with (try discriminate). - intros. unfold is_longconst in *. destruct Archi.splitlong. - eapply SplitLongproof.is_longconst_sound; eauto. - assert (a = Eop (Olongconst n) Enil). - { destruct a... destruct o... destruct e0... congruence. } - subst a. InvEval. auto. -Qed. - -Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword. -Proof. - unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong. - red; intros. destruct (is_longconst a) as [n|] eqn:C. -- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto. -- TrivialExists. -Qed. - -Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu. -Proof. - unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu. - red; intros. destruct (is_intconst a) as [n|] eqn:C. -- econstructor; split. apply eval_longconst. - exploit is_intconst_sound; eauto. intros; subst x. auto. -- TrivialExists. -Qed. - -Theorem eval_longofint: unary_constructor_sound longofint Val.longofint. -Proof. - unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint. - red; intros. destruct (is_intconst a) as [n|] eqn:C. -- econstructor; split. apply eval_longconst. - exploit is_intconst_sound; eauto. intros; subst x. auto. -- TrivialExists. -Qed. - -Theorem eval_negl: unary_constructor_sound negl Val.negl. -Proof. - unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto. - red; intros. destruct (is_longconst a) as [n|] eqn:C. -- exploit is_longconst_sound; eauto. intros EQ; subst x. - econstructor; split. apply eval_longconst. auto. -- TrivialExists. -Qed. - - -Theorem eval_addlimm_shllimm: - forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)). -Proof. - red; unfold addlimm_shllimm; intros. - destruct (Compopts.optim_addx tt). - { - destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. - - TrivialExists. simpl. - f_equal. - unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. - destruct (Z.eq_dec _ _) as [e1|]. - { replace s14 with SHIFT1 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e1. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e1. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e2|]. - { replace s14 with SHIFT2 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e2. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e2. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e3|]. - { replace s14 with SHIFT3 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e3. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e3. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e4|]. - { replace s14 with SHIFT4 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e4. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e4. - rewrite Int.repr_unsigned. - reflexivity. - } - discriminate. - - unfold addxl. rewrite Val.addl_commut. - TrivialExists. - repeat (try eassumption; try econstructor). - simpl. - reflexivity. - } - { unfold addxl. rewrite Val.addl_commut. - TrivialExists. - repeat (try eassumption; try econstructor). - simpl. - reflexivity. - } -Qed. - -Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)). -Proof. - unfold addlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - subst. exists x; split; auto. - destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto. - destruct (addlimm_match a); InvEval. -- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto. -- destruct (Compopts.optim_globaladdroffset _). - + econstructor; split. EvalOp. simpl; eauto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. - destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto. - + TrivialExists. repeat econstructor. simpl. trivial. -- econstructor; split. EvalOp. simpl; eauto. - destruct sp; simpl; auto. destruct Archi.ptr64; auto. - rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto. -- subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists. -- TrivialExists; simpl. subst x. - destruct v1; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - rewrite Int64.add_assoc. rewrite Int64.add_commut. - reflexivity. -- pose proof eval_addlimm_shllimm as ADDXL. - unfold unary_constructor_sound in ADDXL. - unfold addxl in ADDXL. - rewrite Val.addl_commut. - subst x. - apply ADDXL; assumption. -- TrivialExists. -Qed. - -Lemma eval_addxl: forall n, binary_constructor_sound (addl_shllimm n) (ExtValues.addxl n). -Proof. - red. - intros. - unfold addl_shllimm. - destruct (Compopts.optim_addx tt). - { - destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. - - TrivialExists. - simpl. - f_equal. f_equal. - unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. - destruct (Z.eq_dec _ _) as [e1|]. - { replace s14 with SHIFT1 by congruence. - rewrite <- e1. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e2|]. - { replace s14 with SHIFT2 by congruence. - rewrite <- e2. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e3|]. - { replace s14 with SHIFT3 by congruence. - rewrite <- e3. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e4|]. - { replace s14 with SHIFT4 by congruence. - rewrite <- e4. - apply Int.repr_unsigned. } - discriminate. - (* Oaddxl *) - - TrivialExists; - repeat econstructor; eassumption. - } - { TrivialExists; - repeat econstructor; eassumption. - } -Qed. - -Theorem eval_addl: binary_constructor_sound addl Val.addl. -Proof. - unfold addl. destruct Archi.splitlong eqn:SL. - apply SplitLongproof.eval_addl. apply Archi.splitlong_ptr32; auto. -(* - assert (SF: Archi.ptr64 = true). - { Local Transparent Archi.splitlong. unfold Archi.splitlong in SL. - destruct Archi.ptr64; simpl in *; congruence. } -*) -(* - assert (B: forall id ofs n, - Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) = - Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))). - { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs. - apply Genv.shift_symbol_address_64; auto. } - -*) - red; intros until y. - case (addl_match a b); intros; InvEval. - - rewrite Val.addl_commut. apply eval_addlimm; auto. - - apply eval_addlimm; auto. - - subst. - replace (Val.addl (Val.addl v1 (Vlong n1)) (Val.addl v0 (Vlong n2))) - with (Val.addl (Val.addl v1 v0) (Val.addl (Vlong n1) (Vlong n2))). - apply eval_addlimm. EvalOp. - repeat rewrite Val.addl_assoc. decEq. apply Val.addl_permut. - - subst. econstructor; split. - EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. - rewrite Val.addl_commut. destruct sp; simpl; auto. - destruct v1; simpl; auto. - destruct Archi.ptr64 eqn:SF; auto. - apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. - rewrite (Ptrofs.add_commut (Ptrofs.of_int64 n1)), Ptrofs.add_assoc. f_equal. auto with ptrofs. - - subst. econstructor; split. - EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. - destruct sp; simpl; auto. - destruct v1; simpl; auto. - destruct Archi.ptr64 eqn:SF; auto. - apply Val.lessdef_same. f_equal. rewrite ! Ptrofs.add_assoc. f_equal. f_equal. - rewrite Ptrofs.add_commut. auto with ptrofs. - - subst. - replace (Val.addl (Val.addl v1 (Vlong n1)) y) - with (Val.addl (Val.addl v1 y) (Vlong n1)). - apply eval_addlimm. EvalOp. - repeat rewrite Val.addl_assoc. decEq. apply Val.addl_commut. - - subst. - replace (Val.addl x (Val.addl v1 (Vlong n2))) - with (Val.addl (Val.addl x v1) (Vlong n2)). - apply eval_addlimm. EvalOp. - repeat rewrite Val.addl_assoc. reflexivity. - - subst. TrivialExists. - - subst. rewrite Val.addl_commut. TrivialExists. - - subst. TrivialExists. - - subst. rewrite Val.addl_commut. TrivialExists. - - subst. pose proof eval_addxl as ADDXL. - unfold binary_constructor_sound in ADDXL. - rewrite Val.addl_commut. - apply ADDXL; assumption. - (* Oaddxl *) - - subst. pose proof eval_addxl as ADDXL. - unfold binary_constructor_sound in ADDXL. - apply ADDXL; assumption. - - TrivialExists. -Qed. - -Theorem eval_subl: binary_constructor_sound subl Val.subl. -Proof. - unfold subl. destruct Archi.splitlong eqn:SL. - apply SplitLongproof.eval_subl. apply Archi.splitlong_ptr32; auto. - red; intros; destruct (subl_match a b); InvEval. -- rewrite Val.subl_addl_opp. apply eval_addlimm; auto. -- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r. - rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp. - apply eval_addlimm; EvalOp. -- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp. -- subst. rewrite Val.subl_addl_r. - apply eval_addlimm; EvalOp. -- TrivialExists. simpl. subst. reflexivity. -- TrivialExists. simpl. subst. - destruct v1; destruct x; simpl; trivial. - + f_equal. f_equal. - rewrite <- Int64.neg_mul_distr_r. - rewrite Int64.sub_add_opp. - reflexivity. - + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial. - f_equal. f_equal. - rewrite <- Int64.neg_mul_distr_r. - rewrite Ptrofs.sub_add_opp. - unfold Ptrofs.add. - f_equal. f_equal. - rewrite (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 (Int64.mul i n)) (Int64.mul i n)). - rewrite (Ptrofs.agree64_of_int ARCHI64 (Int64.neg (Int64.mul i n))). - reflexivity. - apply (Ptrofs.agree64_of_int ARCHI64). -- TrivialExists. -Qed. - -Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)). -Proof. - intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto. - red; intros. - predSpec Int.eq Int.eq_spec n Int.zero. - exists x; split; auto. subst n; destruct x; simpl; auto. - destruct (Int.ltu Int.zero Int64.iwordsize'); auto. - change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v - /\ Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists. - destruct (shllimm_match a); InvEval. -- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. -- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. - subst. econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; auto. rewrite LT'. - destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. - simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto. -- apply DEFAULT. -- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. -Qed. - -Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)). -Proof. - intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto. - red; intros. - predSpec Int.eq Int.eq_spec n Int.zero. - exists x; split; auto. subst n; destruct x; simpl; auto. - destruct (Int.ltu Int.zero Int64.iwordsize'); auto. - change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v - /\ Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists. - destruct (shrluimm_match a); InvEval. -- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. -- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. - subst. econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; auto. rewrite LT'. - destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. - simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto. -- subst x. - simpl negb. - cbn iota. - destruct (is_bitfieldl _ _) eqn:BOUNDS. - + exists (extfzl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int64.zwordsize) v1). - split. - ++ EvalOp. - ++ unfold extfzl. - rewrite BOUNDS. - destruct v1; try (simpl; apply Val.lessdef_undef). - replace (Z.sub Int64.zwordsize - (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. - replace (Z.sub Int64.zwordsize - (Z.sub - (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. - simpl. - destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. - destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. - rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - constructor. - + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. -- apply DEFAULT. -- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. -Qed. - -Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)). -Proof. - intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto. - red; intros. - predSpec Int.eq Int.eq_spec n Int.zero. - exists x; split; auto. subst n; destruct x; simpl; auto. - destruct (Int.ltu Int.zero Int64.iwordsize'); auto. - change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto. - destruct (Int.ltu n Int64.iwordsize') eqn:LT. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v - /\ Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists. - destruct (shrlimm_match a); InvEval. -- econstructor; split. apply eval_longconst. simpl; rewrite LT; auto. -- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto. - subst. econstructor; split. EvalOp. simpl; eauto. - destruct v1; simpl; auto. rewrite LT'. - destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto. - simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto. -- subst x. - simpl negb. - cbn iota. - destruct (is_bitfieldl _ _) eqn:BOUNDS. - + exists (extfsl (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int64.zwordsize) v1). - split. - ++ EvalOp. - ++ unfold extfsl. - rewrite BOUNDS. - destruct v1; try (simpl; apply Val.lessdef_undef). - replace (Z.sub Int64.zwordsize - (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. - replace (Z.sub Int64.zwordsize - (Z.sub - (Z.add (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int64.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int64.zwordsize))) with (Int.unsigned n) by omega. - simpl. - destruct (Int.ltu n1 Int64.iwordsize') eqn:Hltu_n1; simpl; trivial. - destruct (Int.ltu n Int64.iwordsize') eqn:Hltu_n; simpl; trivial. - rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - constructor. - + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. -- apply DEFAULT. -- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto. -Qed. - -Theorem eval_shll: binary_constructor_sound shll Val.shll. -Proof. - unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto. - red; intros. destruct (is_intconst b) as [n2|] eqn:C. -- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto. -- TrivialExists. -Qed. - -Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu. -Proof. - unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto. - red; intros. destruct (is_intconst b) as [n2|] eqn:C. -- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto. -- TrivialExists. -Qed. - -Theorem eval_shrl: binary_constructor_sound shrl Val.shrl. -Proof. - unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto. - red; intros. destruct (is_intconst b) as [n2|] eqn:C. -- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto. -- TrivialExists. -Qed. - -Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)). -Proof. - intros; unfold mullimm_base. red; intros. - assert (DEFAULT: exists v, - eval_expr ge sp e m le (Eop Omull (a ::: longconst n ::: Enil)) v - /\ Val.lessdef (Val.mull x (Vlong n)) v). - { econstructor; split. EvalOp. constructor. eauto. constructor. apply eval_longconst. constructor. simpl; eauto. - auto. } - generalize (Int64.one_bits'_decomp n); intros D. - destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B. -- TrivialExists. -- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)). - apply eval_shllimm; auto. - simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto. - rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib). - rewrite Int64.shl'_mul; auto. -- set (le' := x :: le). - assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity). - exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1). - exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2). - exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3). - exists v3; split. econstructor; eauto. - rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto. - simpl in *. - rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib). - rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib). - inv B1; inv B2. simpl in B3; inv B3. - rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto. -- TrivialExists. -Qed. - -Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)). -Proof. - unfold mullimm. intros; red; intros. - destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_mullimm; eauto. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists (Vlong Int64.zero); split. apply eval_longconst. - destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.one. - exists x; split; auto. - destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto. - destruct (mullimm_match a); InvEval. -- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto. -- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2). - exploit (eval_addlimm (Int64.mul n n2)). eexact A2. intros (v3 & A3 & B3). - exists v3; split; auto. - subst x. destruct v1; simpl; auto. - simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l. - rewrite (Int64.mul_commut n). auto. -- apply eval_mullimm_base; auto. -Qed. - -Theorem eval_mull: binary_constructor_sound mull Val.mull. -Proof. - unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto. - red; intros; destruct (mull_match a b); InvEval. -- rewrite Val.mull_commut. apply eval_mullimm; auto. -- apply eval_mullimm; auto. -- TrivialExists. -Qed. - -Theorem eval_mullhu: - forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)). -Proof. - unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto. - red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. -Qed. - -Theorem eval_mullhs: - forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)). -Proof. - unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto. - red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto. -Qed. - -Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)). -Proof. - unfold andlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists (Vlong Int64.zero); split. apply eval_longconst. - subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone. - exists x; split. assumption. - subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto. - destruct (andlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto. -- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto. -- TrivialExists. -- TrivialExists. -Qed. - -Lemma int64_eq_commut: forall x y : int64, - (Int64.eq x y) = (Int64.eq y x). -Proof. - intros. - predSpec Int64.eq Int64.eq_spec x y; - predSpec Int64.eq Int64.eq_spec y x; - congruence. -Qed. - -Theorem eval_andl: binary_constructor_sound andl Val.andl. -Proof. - unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl. - red; intros. destruct (andl_match a b). -- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto. -- InvEval. apply eval_andlimm; auto. -- (*andn*) InvEval. TrivialExists. simpl. congruence. -- (*andn reverse*) InvEval. rewrite Val.andl_commut. TrivialExists; simpl. congruence. - (* -- (* selectl *) - InvEval. - predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; TrivialExists. - + constructor. econstructor; constructor. - constructor; try constructor; try constructor; try eassumption. - + simpl in *. f_equal. inv H6. - unfold selectl. - simpl. - destruct v3; simpl; trivial. - rewrite int64_eq_commut. - destruct (Int64.eq i Int64.zero); simpl. - * replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve. - destruct y; simpl; trivial. - * replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve. - destruct y; simpl; trivial. - rewrite Int64.and_commut. rewrite Int64.and_mone. reflexivity. - + constructor. econstructor. constructor. econstructor. constructor. econstructor. constructor. eassumption. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. simpl. f_equal. constructor. eassumption. constructor. - + simpl in *. congruence. *) -- TrivialExists. -Qed. - -Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)). -Proof. - unfold orlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto. - predSpec Int64.eq Int64.eq_spec n Int64.mone. - econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto. - destruct (orlimm_match a); InvEval; subst. -- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto. -- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto. -- InvEval. TrivialExists. -- TrivialExists. -Qed. - - -Theorem eval_orl: binary_constructor_sound orl Val.orl. -Proof. - unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl. - red; intros. - destruct (orl_match a b). -- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto. -- InvEval. apply eval_orlimm; auto. -- (*orn*) InvEval. TrivialExists; simpl; congruence. -- (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence. - - - (*insfl first case*) - destruct (is_bitfieldl _ _) eqn:Risbitfield. - + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. - * rewrite Rnmask in *. - inv H. inv H0. inv H4. inv H3. inv H9. inv H8. - simpl in H6, H7. - inv H6. inv H7. - inv H4. inv H3. inv H7. - simpl in H6. - inv H6. - set (zstop := (int64_highest_bit mask)) in *. - set (zstart := (Int.unsigned start)) in *. - - TrivialExists. - simpl. f_equal. - - unfold insfl. - rewrite Risbitfield. - rewrite Rmask. - simpl. - unfold bitfield_maskl. - subst zstart. - rewrite Int.repr_unsigned. - reflexivity. - * TrivialExists. - + TrivialExists. - - destruct (is_bitfieldl _ _) eqn:Risbitfield. - + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. - * rewrite Rnmask in *. - inv H. inv H0. inv H4. inv H6. inv H8. inv H3. inv H8. - inv H0. simpl in H7. inv H7. - set (zstop := (int64_highest_bit mask)) in *. - set (zstart := 0) in *. - - TrivialExists. simpl. f_equal. - unfold insfl. - rewrite Risbitfield. - rewrite Rmask. - simpl. - subst zstart. - f_equal. - destruct v0; simpl; trivial. - unfold Int.ltu, Int64.iwordsize', Int64.zwordsize, Int64.wordsize. - rewrite Int.unsigned_repr. - ** rewrite Int.unsigned_repr. - *** simpl. - rewrite Int64.shl'_zero. - reflexivity. - *** simpl. unfold Int.max_unsigned. unfold Int.modulus. - simpl. omega. - ** unfold Int.max_unsigned. unfold Int.modulus. - simpl. omega. - * TrivialExists. - + TrivialExists. -- TrivialExists. -Qed. - -Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)). -Proof. - unfold xorlimm; intros; red; intros. - predSpec Int64.eq Int64.eq_spec n Int64.zero. - - exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto. - - predSpec Int64.eq Int64.eq_spec n Int64.mone. - -- subst n. intros. rewrite <- Val.notl_xorl. TrivialExists. - -- destruct (xorlimm_match a); InvEval; subst. - + econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto. - + rewrite Val.xorl_assoc. simpl. rewrite (Int64.xor_commut n2). - predSpec Int64.eq Int64.eq_spec (Int64.xor n n2) Int64.zero. - * rewrite H. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.xor_zero; auto. - * TrivialExists. - + TrivialExists. -Qed. - -Theorem eval_xorl: binary_constructor_sound xorl Val.xorl. -Proof. - unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl. - red; intros. destruct (xorl_match a b). -- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto. -- InvEval. apply eval_xorlimm; auto. -- TrivialExists. -Qed. - -Theorem eval_notl: unary_constructor_sound notl Val.notl. -Proof. - assert (forall v, Val.lessdef (Val.notl (Val.notl v)) v). - destruct v; simpl; auto. rewrite Int64.not_involutive; auto. - unfold notl; red; intros until x; case (notl_match a); intros; InvEval. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - subst x. exists (Val.andl v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.andl v1 (Vlong n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - - subst x. exists (Val.orl v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.orl v1 (Vlong n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - - subst x. exists (Val.xorl v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.xorl v1 (Vlong n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - (* andn *) - - subst x. TrivialExists. simpl. - destruct v0; destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int64.not_and_or_not. - rewrite Int64.not_involutive. - apply Int64.or_commut. - - subst x. TrivialExists. simpl. - destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int64.not_and_or_not. - rewrite Int64.not_involutive. - reflexivity. - (* orn *) - - subst x. TrivialExists. simpl. - destruct v0; destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int64.not_or_and_not. - rewrite Int64.not_involutive. - apply Int64.and_commut. - - subst x. TrivialExists. simpl. - destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int64.not_or_and_not. - rewrite Int64.not_involutive. - reflexivity. - - subst x. exists v1; split; trivial. - - TrivialExists. - - TrivialExists. -Qed. - -Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls. -Proof. - unfold divls_base; red; intros. - eapply SplitLongproof.eval_divls_base; eauto. -Qed. - -Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls. -Proof. - unfold modls_base; red; intros. - eapply SplitLongproof.eval_modls_base; eauto. -Qed. - -Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu. -Proof. - unfold divlu_base; red; intros. - eapply SplitLongproof.eval_divlu_base; eauto. -Qed. - -Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu. -Proof. - unfold modlu_base; red; intros. - eapply SplitLongproof.eval_modlu_base; eauto. -Qed. - -Theorem eval_shrxlimm: - forall le a n x z, - eval_expr ge sp e m le a x -> - Val.shrxl x (Vint n) = Some z -> - exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v. -Proof. - unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL. -+ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32. -+ predSpec Int.eq Int.eq_spec n Int.zero. -- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto. - change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto. -- TrivialExists. simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_cmplu: - forall c le a x b y v, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.cmplu (Mem.valid_pointer m) c x y = Some v -> - eval_expr ge sp e m le (cmplu c a b) v. -Proof. - unfold cmplu; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32. - unfold Val.cmplu in H1. - destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1. - destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; - try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); - try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); - subst. -- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity. -- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto. -- EvalOp. simpl; rewrite C; auto. -- EvalOp. simpl; rewrite C; auto. -Qed. - -Theorem eval_cmpl: - forall c le a x b y v, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.cmpl c x y = Some v -> - eval_expr ge sp e m le (cmpl c a b) v. -Proof. - unfold cmpl; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_cmpl; eauto. - unfold Val.cmpl in H1. - destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1. - destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2; - try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto)); - try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto)); - subst. -- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity. -- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto. -- EvalOp. simpl; rewrite C; auto. -- EvalOp. simpl; rewrite C; auto. -Qed. - -Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat. -Proof. - unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_longoffloat; eauto. - TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat. -Proof. - unfold longuoffloat; red; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_longuoffloat; eauto. - TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong. -Proof. - unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_floatoflong; eauto. - TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu. -Proof. - unfold floatoflongu; red; intros. destruct Archi.splitlong eqn:SL. - eapply SplitLongproof.eval_floatoflongu; eauto. - TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle. -Proof. - unfold longofsingle; red; intros. - destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2. - exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. - apply Float32.to_long_double in EQ. - eapply eval_longoffloat; eauto. simpl. - change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. -Qed. - -Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle. -Proof. - unfold longuofsingle; red; intros. (* destruct Archi.splitlong eqn:SL. *) - destruct x; simpl in H0; inv H0. destruct (Float32.to_longu f) as [n|] eqn:EQ; simpl in H2; inv H2. - exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B. - apply Float32.to_longu_double in EQ. - eapply eval_longuoffloat; eauto. simpl. - change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto. -Qed. - -Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong. -Proof. - unfold singleoflong; red; intros. (* destruct Archi.splitlong eqn:SL. *) - eapply SplitLongproof.eval_singleoflong; eauto. -(* TrivialExists. *) -Qed. - -Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu. -Proof. - unfold singleoflongu; red; intros. (* destruct Archi.splitlong eqn:SL. *) - eapply SplitLongproof.eval_singleoflongu; eauto. -(* TrivialExists. *) -Qed. - -End CMCONSTR. diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp deleted file mode 100644 index 9e5d45a0..00000000 --- a/mppa_k1c/SelectOp.vp +++ /dev/null @@ -1,715 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - - -(** Instruction selection for operators *) - -(** The instruction selection pass recognizes opportunities for using - combined arithmetic and logical operations and addressing modes - offered by the target processor. For instance, the expression [x + 1] - can take advantage of the "immediate add" instruction of the processor, - and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned - into a "rotate and mask" instruction. - - This file defines functions for building CminorSel expressions and - statements, especially expressions consisting of operator - applications. These functions examine their arguments to choose - cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a CminorSel expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - On top of the "smart constructor" functions defined below, - module [Selection] implements the actual instruction selection pass. -*) - -Require Archi. -Require Import Coqlib. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Import CminorSel. -Require Import OpHelpers. -Require Import ExtValues ExtFloats. -Require Import DecBoolOps. -Require Import Chunks. -Require Import Builtins. -Require Compopts. - -Local Open Scope cminorsel_scope. - -Local Open Scope string_scope. -Local Open Scope error_monad_scope. - -Section SELECT. - -Context {hf: helper_functions}. - -Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) := - match cond, args with - | (Ccompimm c x), (e1 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccomp0 c), e1) - else None - - | (Ccompuimm c x), (e1 ::: Enil) => - if Int.eq_dec x Int.zero - then Some ((Ccompu0 c), e1) - else None - - | (Ccomplimm c x), (e1 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccompl0 c), e1) - else None - - | (Ccompluimm c x), (e1 ::: Enil) => - if Int64.eq_dec x Int64.zero - then Some ((Ccomplu0 c), e1) - else None - - | _, _ => None - end. - -(** Ternary operator *) -Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) := - match ty, cond0, e1, e2, e3 with - | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 => - (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil)) - | Tint, cond0, (Eop (Ointconst imm) Enil), e2, e3 => - (Eop (Oselimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) - | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 => - (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil)) - | Tlong, cond0, (Eop (Olongconst imm) Enil), e2, e3 => - (Eop (Osellimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil)) - | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil)) - end. - -Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr := - Some( - match cond_to_condition0 cond args with - | None => select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args) - | Some(cond0, ec) => select0 ty cond0 e1 e2 ec - end). - - -(** ** Constants **) - -Definition addrsymbol (id: ident) (ofs: ptrofs) := - Eop (Oaddrsymbol id ofs) Enil. - -Definition addrstack (ofs: ptrofs) := - Eop (Oaddrstack ofs) Enil. - -(** ** Integer addition and pointer addition *) - -Definition addimm_shlimm sh k2 e1 := - if Compopts.optim_addx tt - then - match shift1_4_of_z (Int.unsigned sh) with - | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil) - | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil) - end - else Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil). - -Nondetfunction addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil - | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil - | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil - | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | Eop (Oaddximm sh m) (t ::: Enil) => Eop (Oaddximm sh (Int.add n m)) (t ::: Enil) - | Eop (Oshlimm sh) (t1:::Enil) => addimm_shlimm sh n t1 - | _ => Eop (Oaddimm n) (e ::: Enil) - end. - -Definition add_shlimm n e1 e2 := - if Compopts.optim_addx tt - then - match shift1_4_of_z (Int.unsigned n) with - | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil) - | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil) - end - else Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil). - -Nondetfunction add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil => - Eop Oadd (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n1) n2)) Enil ::: t1 ::: Enil) - | Eop (Oaddrstack n1) Enil, Eop (Oaddimm n2) (t2:::Enil) => - Eop Oadd (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int n2))) Enil ::: t2 ::: Enil) - | Eop (Oaddimm n1) (t1:::Enil), t2 => - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | t1, (Eop Omul (t2:::t3:::Enil)) => - if Compopts.optim_madd tt - then Eop Omadd (t1:::t2:::t3:::Enil) - else Eop Oadd (e1:::e2:::Enil) - | (Eop Omul (t2:::t3:::Enil)), t1 => - if Compopts.optim_madd tt - then Eop Omadd (t1:::t2:::t3:::Enil) - else Eop Oadd (e1:::e2:::Enil) - | t1, (Eop (Omulimm n) (t2:::Enil)) => - if Compopts.optim_madd tt - then Eop (Omaddimm n) (t1:::t2:::Enil) - else Eop Oadd (e1:::e2:::Enil) - | (Eop (Omulimm n) (t2:::Enil)), t1 => - if Compopts.optim_madd tt - then Eop (Omaddimm n) (t1:::t2:::Enil) - else Eop Oadd (e1:::e2:::Enil) - | (Eop (Oshlimm n) (t1:::Enil)), t2 => - add_shlimm n t1 t2 - | t2, (Eop (Oshlimm n) (t1:::Enil)) => - add_shlimm n t1 t2 - | _, _ => Eop Oadd (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -Nondetfunction sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => - addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | t1, (Eop Omul (t2:::t3:::Enil)) => - Eop Omsub (t1:::t2:::t3:::Enil) - | t1, (Eop (Omulimm n) (t2:::Enil)) => - if Compopts.optim_madd tt - then Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil) - else Eop Osub (e1:::e2:::Enil) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. - -Nondetfunction negint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil - | _ => Eop Oneg (e ::: Enil) - end. - -(** ** Immediate shifts *) - -Nondetfunction shlimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shl n1 n)) Enil - | Eop (Oshlimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshlimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshlimm n) (e1:::Enil) - | _ => - Eop (Oshlimm n) (e1:::Enil) - end. - -Nondetfunction shruimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shru n1 n)) Enil - | Eop (Oshruimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshruimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshruimm n) (e1:::Enil) - | Eop (Oshlimm n1) (t1:::Enil) => - let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in - let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in - if is_bitfield stop start - then Eop (Oextfz stop start) (t1:::Enil) - else Eop (Oshruimm n) (e1:::Enil) - | _ => - Eop (Oshruimm n) (e1:::Enil) - end. - -Nondetfunction shrimm (e1: expr) (n: int) := - if Int.eq n Int.zero then - e1 - else if negb (Int.ltu n Int.iwordsize) then - Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) - else match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst (Int.shr n1 n)) Enil - | Eop (Oshrimm n1) (t1:::Enil) => - if Int.ltu (Int.add n n1) Int.iwordsize - then Eop (Oshrimm (Int.add n n1)) (t1:::Enil) - else Eop (Oshrimm n) (e1:::Enil) - | Eop (Oshlimm n1) (t1:::Enil) => - let stop := Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one) in - let start := Z.sub (Z.add (Z.add (Int.unsigned n) stop) Z.one) Int.zwordsize in - if is_bitfield stop start - then Eop (Oextfs stop start) (t1:::Enil) - else Eop (Oshrimm n) (e1:::Enil) - | _ => - Eop (Oshrimm n) (e1:::Enil) - end. - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) - | _ => - Eop (Omulimm n1) (e2 ::: Enil) - end. - -Nondetfunction mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.one then e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. - -Nondetfunction mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. - -Definition mulhs (e1: expr) (e2: expr) := - if Archi.ptr64 then - Eop Olowlong - (Eop (Oshrlimm (Int.repr 32)) - (Eop Omull (Eop Ocast32signed (e1 ::: Enil) ::: - Eop Ocast32signed (e2 ::: Enil) ::: Enil) ::: Enil) - ::: Enil) - else - Eop Omulhs (e1 ::: e2 ::: Enil). - -Definition mulhu (e1: expr) (e2: expr) := - if Archi.ptr64 then - Eop Olowlong - (Eop (Oshrluimm (Int.repr 32)) - (Eop Omull (Eop Ocast32unsigned (e1 ::: Enil) ::: - Eop Ocast32unsigned (e2 ::: Enil) ::: Enil) ::: Enil) - ::: Enil) - else - Eop Omulhu (e1 ::: e2 ::: Enil). - -(** ** Bitwise and, or, xor *) - -Nondetfunction andimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil - else if Int.eq n1 Int.mone then e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil - | Eop (Oandimm n2) (t2:::Enil) => Eop (Oandimm (Int.and n1 n2)) (t2:::Enil) - | Eop Onot (t2:::Enil) => Eop (Oandnimm n1) (t2:::Enil) - | _ => Eop (Oandimm n1) (e2:::Enil) - end. - -Nondetfunction and (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => andimm n1 t2 - | t1, Eop (Ointconst n2) Enil => andimm n2 t1 - | (Eop Onot (t1:::Enil)), t2 => Eop Oandn (t1:::t2:::Enil) - | t1, (Eop Onot (t2:::Enil)) => Eop Oandn (t2:::t1:::Enil) - | _, _ => Eop Oand (e1:::e2:::Enil) - end. - -Nondetfunction orimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then e2 - else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil - | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil) - | Eop Onot (t2:::Enil) => Eop (Oornimm n1) (t2:::Enil) - | _ => Eop (Oorimm n1) (e2:::Enil) - end. - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -Nondetfunction or (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => orimm n1 t2 - | t1, Eop (Ointconst n2) Enil => orimm n2 t1 - | Eop (Oshlimm n1) (t1:::Enil), Eop (Oshruimm n2) (t2:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | Eop (Oshruimm n2) (t2:::Enil), Eop (Oshlimm n1) (t1:::Enil) => - if Int.eq (Int.add n1 n2) Int.iwordsize && same_expr_pure t1 t2 - then Eop (Ororimm n2) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil) - | t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil) - | (Eop (Oandimm nmask) (prev:::Enil)), - (Eop (Oandimm mask) - ((Eop (Oshlimm start) (fld:::Enil)):::Enil)) => - let zstart := Int.unsigned start in - let zstop := int_highest_bit mask in - if is_bitfield zstop zstart - then - let mask' := Int.repr (zbitfield_mask zstop zstart) in - if and_dec (Int.eq_dec mask mask') - (Int.eq_dec nmask (Int.not mask')) - then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) - else Eop Oor (e1:::e2:::Enil) - else Eop Oor (e1:::e2:::Enil) - | (Eop (Oandimm nmask) (prev:::Enil)), - (Eop (Oandimm mask) (fld:::Enil)) => - let zstart := 0 in - let zstop := int_highest_bit mask in - if is_bitfield zstop zstart - then - let mask' := Int.repr (zbitfield_mask zstop zstart) in - if and_dec (Int.eq_dec mask mask') - (Int.eq_dec nmask (Int.not mask')) - then Eop (Oinsf zstop zstart) (prev:::fld:::Enil) - else Eop Oor (e1:::e2:::Enil) - else Eop Oor (e1:::e2:::Enil) - | _, _ => Eop Oor (e1:::e2:::Enil) - end. - -Nondetfunction xorimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero - then e2 - else - if Int.eq n1 Int.mone - then Eop Onot (e2:::Enil) - else - match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil - | Eop (Oxorimm n2) (t2:::Enil) => - let n := Int.xor n1 n2 in - if Int.eq n Int.zero then t2 else Eop (Oxorimm n) (t2:::Enil) - | _ => Eop (Oxorimm n1) (e2:::Enil) - end. - -Nondetfunction xor (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2 - | t1, Eop (Ointconst n2) Enil => xorimm n2 t1 - | _, _ => Eop Oxor (e1:::e2:::Enil) - end. - -(** ** Integer logical negation *) - -Nondetfunction notint (e: expr) := - match e with - | Eop Oand (e1:::e2:::Enil) => Eop Onand (e1:::e2:::Enil) - | Eop (Oandimm n) (e1:::Enil) => Eop (Onandimm n) (e1:::Enil) - | Eop Oor (e1:::e2:::Enil) => Eop Onor (e1:::e2:::Enil) - | Eop (Oorimm n) (e1:::Enil) => Eop (Onorimm n) (e1:::Enil) - | Eop Oxor (e1:::e2:::Enil) => Eop Onxor (e1:::e2:::Enil) - | Eop (Oxorimm n) (e1:::Enil) => Eop (Onxorimm n) (e1:::Enil) - | Eop Onand (e1:::e2:::Enil) => Eop Oand (e1:::e2:::Enil) - | Eop (Onandimm n) (e1:::Enil) => Eop (Oandimm n) (e1:::Enil) - | Eop Onor (e1:::e2:::Enil) => Eop Oor (e1:::e2:::Enil) - | Eop (Onorimm n) (e1:::Enil) => Eop (Oorimm n) (e1:::Enil) - | Eop Onxor (e1:::e2:::Enil) => Eop Oxor (e1:::e2:::Enil) - | Eop (Onxorimm n) (e1:::Enil) => Eop (Oxorimm n) (e1:::Enil) - | Eop Oandn (e1:::e2:::Enil) => Eop Oorn (e2:::e1:::Enil) - | Eop (Oandnimm n) (e1:::Enil) => Eop (Oorimm (Int.not n)) (e1:::Enil) - | Eop Oorn (e1:::e2:::Enil) => Eop Oandn (e2:::e1:::Enil) - | Eop (Oornimm n) (e1:::Enil) => Eop (Oandimm (Int.not n)) (e1:::Enil) - | Eop Onot (e1:::Enil) => e1 - | Eop (Ointconst k) Enil => Eop (Ointconst (Int.not k)) Enil - | _ => Eop Onot (e:::Enil) - end. - -(** ** Integer division and modulus *) - -Definition divs_base (e1: expr) (e2: expr) := - Eexternal i32_sdiv sig_ii_i (e1 ::: e2 ::: Enil). - -Definition mods_base (e1: expr) (e2: expr) := - Eexternal i32_smod sig_ii_i (e1 ::: e2 ::: Enil). - -Definition divu_base (e1: expr) (e2: expr) := - Eexternal i32_udiv sig_ii_i (e1 ::: e2 ::: Enil). - -Definition modu_base (e1: expr) (e2: expr) := - Eexternal i32_umod sig_ii_i (e1 ::: e2 ::: Enil). - -Definition shrximm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil). - -(* Alternate definition, not convenient for strength reduction during constant propagation *) -(* -(* n2 will be less than 31. *) - -Definition shrximm_inner (e1: expr) (n2: int) := - Eop (Oshruimm (Int.sub Int.iwordsize n2)) - ((Eop (Oshrimm (Int.repr (Int.zwordsize - 1))) - (e1 ::: Enil)) - ::: Enil). - -Definition shrximm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then e1 - else Eop (Oshrimm n2) - ((Eop Oadd (e1 ::: shrximm_inner e1 n2 ::: Enil)) - ::: Enil). -*) - -(** ** General shifts *) - -Nondetfunction shl (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shlimm e1 n2 - | _ => Eop Oshl (e1:::e2:::Enil) - end. - -Nondetfunction shr (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shrimm e1 n2 - | _ => Eop Oshr (e1:::e2:::Enil) - end. - -Nondetfunction shru (e1: expr) (e2: expr) := - match e2 with - | Eop (Ointconst n2) Enil => shruimm e1 n2 - | _ => Eop Oshru (e1:::e2:::Enil) - end. - -(** ** Floating-point arithmetic *) - -Definition negf (e: expr) := Eop Onegf (e ::: Enil). -Definition absf (e: expr) := Eop Oabsf (e ::: Enil). -Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil). -Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil). -Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil). - -Definition negfs (e: expr) := Eop Onegfs (e ::: Enil). -Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil). -Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil). -Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil). -Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil). - -(** ** Comparisons *) - -Nondetfunction compimm (default: comparison -> int -> condition) - (sem: comparison -> int -> int -> bool) - (c: comparison) (e1: expr) (n2: int) := - match c, e1 with - | c, Eop (Ointconst n1) Enil => - Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil - | Ceq, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp (negate_condition c)) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp c) el - else - Eop (Ointconst Int.zero) Enil - | Cne, Eop (Ocmp c) el => - if Int.eq_dec n2 Int.zero then - Eop (Ocmp c) el - else if Int.eq_dec n2 Int.one then - Eop (Ocmp (negate_condition c)) el - else - Eop (Ointconst Int.one) Enil - | _, _ => - Eop (Ocmp (default c n2)) (e1 ::: Enil) - end. - -Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompimm Int.cmp (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompimm Int.cmp c t1 n2 - | _, _ => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => - compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1 - | t1, Eop (Ointconst n2) Enil => - compimm Ccompuimm Int.cmpu c t1 n2 - | _, _ => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -Definition compfs (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil). - -(** ** Integer conversions *) - -Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e. - -Nondetfunction cast8signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 8 n)) Enil - | _ => Eop Ocast8signed (e ::: Enil) - end. - -Definition cast16unsigned (e: expr) := andimm (Int.repr 65535) e. - -Nondetfunction cast16signed (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext 16 n)) Enil - | _ => Eop Ocast16signed (e ::: Enil) - end. - -(** ** Floating-point conversions *) - -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). -Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil). - -Nondetfunction floatofintu (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil - | _ => Eop Ofloatoflongu ((Eop Ocast32unsigned (e ::: Enil)) ::: Enil) - end. - -Nondetfunction floatofint (e: expr) := - match e with - | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil - | _ => Eop Ofloatoflong ((Eop Ocast32signed (e ::: Enil)) ::: Enil) - end. - -Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil). -Definition singleofint (e: expr) := Eop Osingleofint (e ::: Enil). - -Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil). -Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil). - -Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil). -Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil). - -(** ** Recognition of addressing modes for load and store operations *) - -Nondetfunction addressing (chunk: memory_chunk) (e: expr) := - match e with - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop (Oaddrsymbol id ofs) Enil => - (if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt))) - then (Aindexed Ptrofs.zero, e:::Enil) - else (Aglobal id ofs, Enil)) - | Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil) - | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil) - | Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) => - (if Compopts.optim_xsaddr tt - then let zscale := Int.unsigned scale in - if Z.eq_dec zscale (zscale_of_chunk chunk) - then (Aindexed2XS zscale, e1:::e2:::Enil) - else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) - else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)) - | Eop (Oaddxl sh) (e1:::e2:::Enil) => - let zscale := ExtValues.z_of_shift1_4 sh in - let scale := Int.repr zscale in - (if Compopts.optim_xsaddr tt - then if Z.eq_dec zscale (zscale_of_chunk chunk) - then (Aindexed2XS zscale, e2:::e1:::Enil) - else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil) - else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil)) - | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) - | _ => (Aindexed Ptrofs.zero, e:::Enil) - end. - -(** ** Arguments of builtins *) - -Nondetfunction builtin_arg (e: expr) := - match e with - | Eop (Ointconst n) Enil => BA_int n - | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs - | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs - | Eop Omakelong (Eop (Ointconst h) Enil ::: Eop (Ointconst l) Enil ::: Enil) => - BA_long (Int64.ofwords h l) - | Eop Omakelong (h ::: l ::: Enil) => BA_splitlong (BA h) (BA l) - | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs - | Eop (Oaddimm n) (e1:::Enil) => - if Archi.ptr64 then BA e else BA_addptr (BA e1) (BA_int n) - | Eop (Oaddlimm n) (e1:::Enil) => - if Archi.ptr64 then BA_addptr (BA e1) (BA_long n) else BA e - | _ => BA e - end. - -(* float division *) - -Definition divf_base (e1: expr) (e2: expr) := - (* Eop Odivf (e1 ::: e2 ::: Enil). *) - Eexternal f64_div sig_ff_f (e1 ::: e2 ::: Enil). - -Definition divfs_base1 (e2 : expr) := - Eop Oinvfs (e2 ::: Enil). -Definition divfs_baseX (e1 : expr) (e2 : expr) := - (* Eop Odivf (e1 ::: e2 ::: Enil). *) - Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil). - -Nondetfunction divfs_base (e1: expr) := - match e1 with - | Eop (Osingleconst f) Enil => - (if Float32.eq_dec f ExtFloat32.one - then divfs_base1 - else divfs_baseX e1) - | _ => divfs_baseX e1 - end. - -Nondetfunction gen_fma args := - match args with - | (Eop Onegf (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubf (e3:::e1:::e2:::Enil)) - | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil)) - | _ => None - end. - -Nondetfunction gen_fmaf args := - match args with - | (Eop Onegfs (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubfs (e3:::e1:::e2:::Enil)) - | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil)) - | _ => None - end. - -Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr := - match b with - | BI_fmin => Some (Eop Ominf args) - | BI_fmax => Some (Eop Omaxf args) - | BI_fminf => Some (Eop Ominfs args) - | BI_fmaxf => Some (Eop Omaxfs args) - | BI_fabsf => Some (Eop Oabsfs args) - | BI_fma => gen_fma args - | BI_fmaf => gen_fmaf args - end. -End SELECT. - -(* Local Variables: *) -(* mode: coq *) -(* End: *) diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v deleted file mode 100644 index d1d0b95c..00000000 --- a/mppa_k1c/SelectOpproof.v +++ /dev/null @@ -1,1735 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Correctness of instruction selection for operators *) - -Require Import Builtins. -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import ExtValues. -Require Import Memory. -Require Import Globalenvs. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import Builtins1. -Require Import SelectOp. -Require Import Events. -Require Import OpHelpers. -Require Import OpHelpersproof. -Require Import DecBoolOps. - -Local Open Scope cminorsel_scope. -Local Open Scope string_scope. - - -(** * Useful lemmas and tactics *) - -(** The following are trivial lemmas and custom tactics that help - perform backward (inversion) and forward reasoning over the evaluation - of operator applications. *) - -Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. - -Ltac InvEval1 := - match goal with - | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => - inv H; InvEval1 - | _ => - idtac - end. - -Ltac InvEval2 := - match goal with - | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => - simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | _ => - idtac - end. - -Ltac InvEval := InvEval1; InvEval2; InvEval2. - -Ltac TrivialExists := - match goal with - | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto] - end. - -(** * Correctness of the smart constructors *) - -Section CMCONSTR. -Variable prog: program. -Variable hf: helper_functions. -Hypothesis HELPERS: helper_functions_declared prog hf. -Let ge := Genv.globalenv prog. -Variable sp: val. -Variable e: env. -Variable m: mem. - -(* Helper lemmas - from SplitLongproof.v *) - -Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto. -Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. - -Lemma eval_helper: - forall le id name sg args vargs vres, - eval_exprlist ge sp e m le args vargs -> - helper_declared prog id name sg -> - external_implements name sg vargs vres -> - eval_expr ge sp e m le (Eexternal id sg args) vres. -Proof. - intros. - red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q). - rewrite <- Genv.find_funct_ptr_iff in Q. - econstructor; eauto. -Qed. - -Corollary eval_helper_1: - forall le id name sg arg1 varg1 vres, - eval_expr ge sp e m le arg1 varg1 -> - helper_declared prog id name sg -> - external_implements name sg (varg1::nil) vres -> - eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres. -Proof. - intros. eapply eval_helper; eauto. constructor; auto. constructor. -Qed. - -Corollary eval_helper_2: - forall le id name sg arg1 arg2 varg1 varg2 vres, - eval_expr ge sp e m le arg1 varg1 -> - eval_expr ge sp e m le arg2 varg2 -> - helper_declared prog id name sg -> - external_implements name sg (varg1::varg2::nil) vres -> - eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. -Proof. - intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor. -Qed. - -(** We now show that the code generated by "smart constructor" functions - such as [Selection.notint] behaves as expected. Continuing the - [notint] example, we show that if the expression [e] - evaluates to some integer value [Vint n], then [Selection.notint e] - evaluates to a value [Vint (Int.not n)] which is indeed the integer - negation of the value of [e]. - - All proofs follow a common pattern: -- Reasoning by case over the result of the classification functions - (such as [add_match] for integer addition), gathering additional - information on the shape of the argument expressions in the non-default - cases. -- Inversion of the evaluations of the arguments, exploiting the additional - information thus gathered. -- Equational reasoning over the arithmetic operations performed, - using the lemmas from the [Int] and [Float] modules. -- Construction of an evaluation derivation for the expression returned - by the smart constructor. -*) - -Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop := - forall le a x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v. - -Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop := - forall le a x b y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v. - -Theorem eval_addrsymbol: - forall le id ofs, - exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v. -Proof. - intros. unfold addrsymbol. econstructor; split. - EvalOp. simpl; eauto. - auto. -Qed. - -Theorem eval_addrstack: - forall le ofs, - exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v. -Proof. - intros. unfold addrstack. econstructor; split. - EvalOp. simpl; eauto. - auto. -Qed. - -Theorem eval_addimm_shlimm: - forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)). -Proof. - red; unfold addimm_shlimm; intros. - destruct (Compopts.optim_addx tt). - { - destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT. - - TrivialExists. simpl. - f_equal. - unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. - destruct (Z.eq_dec _ _) as [e1|]. - { replace s14 with SHIFT1 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e1. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e1. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e2|]. - { replace s14 with SHIFT2 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e2. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e2. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e3|]. - { replace s14 with SHIFT3 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e3. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e3. - rewrite Int.repr_unsigned. - reflexivity. - } - destruct (Z.eq_dec _ _) as [e4|]. - { replace s14 with SHIFT4 by congruence. - destruct x; simpl; trivial. - replace (Int.ltu _ _) with true by reflexivity. - unfold Int.ltu. - rewrite e4. - replace (if zlt _ _ then true else false) with true by reflexivity. - rewrite <- e4. - rewrite Int.repr_unsigned. - reflexivity. - } - discriminate. - - unfold addx. rewrite Val.add_commut. - TrivialExists. - repeat (try eassumption; try econstructor). - simpl. - reflexivity. - } - { unfold addx. rewrite Val.add_commut. - TrivialExists. - repeat (try eassumption; try econstructor). - simpl. - reflexivity. - } -Qed. - -Theorem eval_addimm: - forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)). -Proof. - red; unfold addimm; intros until x. - predSpec Int.eq Int.eq_spec n Int.zero. - - subst n. intros. exists x; split; auto. - destruct x; simpl; auto. - rewrite Int.add_zero; auto. - - case (addimm_match a); intros; InvEval; simpl. - + TrivialExists; simpl. rewrite Int.add_commut. auto. - + econstructor; split. EvalOp. simpl; eauto. - unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto. - + econstructor; split. EvalOp. simpl; eauto. - destruct sp; simpl; auto. - + TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto. - + TrivialExists; simpl. subst x. - destruct v1; simpl; trivial. - destruct (Int.ltu _ _); simpl; trivial. - rewrite Int.add_assoc. rewrite Int.add_commut. - reflexivity. - + pose proof eval_addimm_shlimm as ADDX. - unfold unary_constructor_sound in ADDX. - unfold addx in ADDX. - rewrite Val.add_commut. - subst x. - apply ADDX; assumption. - + TrivialExists. -Qed. - -Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n). -Proof. - red. - intros. - unfold add_shlimm. - destruct (Compopts.optim_addx tt). - { - destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT. - - TrivialExists. - simpl. - f_equal. f_equal. - unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *. - destruct (Z.eq_dec _ _) as [e1|]. - { replace s14 with SHIFT1 by congruence. - rewrite <- e1. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e2|]. - { replace s14 with SHIFT2 by congruence. - rewrite <- e2. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e3|]. - { replace s14 with SHIFT3 by congruence. - rewrite <- e3. - apply Int.repr_unsigned. } - destruct (Z.eq_dec _ _) as [e4|]. - { replace s14 with SHIFT4 by congruence. - rewrite <- e4. - apply Int.repr_unsigned. } - discriminate. - - TrivialExists; - repeat econstructor; eassumption. - } - { TrivialExists; - repeat econstructor; eassumption. - } -Qed. - -Theorem eval_add: binary_constructor_sound add Val.add. -Proof. - red; intros until y. - unfold add; case (add_match a b); intros; InvEval. - - rewrite Val.add_commut. apply eval_addimm; auto. - - apply eval_addimm; auto. - - subst. - replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2))) - with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))). - apply eval_addimm. EvalOp. - repeat rewrite Val.add_assoc. decEq. apply Val.add_permut. - - subst. econstructor; split. - EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. - rewrite Val.add_commut. destruct sp; simpl; auto. - destruct v1; simpl; auto. - - subst. econstructor; split. - EvalOp. constructor. EvalOp. simpl; eauto. constructor. eauto. constructor. simpl; eauto. - destruct sp; simpl; auto. - destruct v1; simpl; auto. - - subst. - replace (Val.add (Val.add v1 (Vint n1)) y) - with (Val.add (Val.add v1 y) (Vint n1)). - apply eval_addimm. EvalOp. - repeat rewrite Val.add_assoc. decEq. apply Val.add_commut. - - subst. - replace (Val.add x (Val.add v1 (Vint n2))) - with (Val.add (Val.add x v1) (Vint n2)). - apply eval_addimm. EvalOp. - repeat rewrite Val.add_assoc. reflexivity. - - (* Omadd *) - subst. destruct (Compopts.optim_madd tt); TrivialExists; - repeat (eauto; econstructor; simpl). - - (* Omadd rev *) - subst. destruct (Compopts.optim_madd tt); TrivialExists; - repeat (eauto; econstructor; simpl). - simpl. rewrite Val.add_commut. reflexivity. - - (* Omaddimm *) - subst. destruct (Compopts.optim_madd tt); TrivialExists; - repeat (eauto; econstructor; simpl). - - (* Omaddimm rev *) - subst. destruct (Compopts.optim_madd tt); TrivialExists; - repeat (eauto; econstructor; simpl). - simpl. rewrite Val.add_commut. reflexivity. - (* Oaddx *) - - subst. pose proof eval_addx as ADDX. - unfold binary_constructor_sound in ADDX. - rewrite Val.add_commut. - apply ADDX; assumption. - (* Oaddx *) - - subst. pose proof eval_addx as ADDX. - unfold binary_constructor_sound in ADDX. - apply ADDX; assumption. - - TrivialExists. -Qed. - -Theorem eval_sub: binary_constructor_sound sub Val.sub. -Proof. - red; intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - - rewrite Val.sub_add_opp. apply eval_addimm; auto. - - subst. rewrite Val.sub_add_l. rewrite Val.sub_add_r. - rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp. - apply eval_addimm; EvalOp. - - subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp. - - subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp. - - TrivialExists. simpl. subst. reflexivity. - - destruct (Compopts.optim_madd tt). - + TrivialExists. simpl. subst. - rewrite sub_add_neg. - rewrite neg_mul_distr_r. - unfold Val.neg. - reflexivity. - + TrivialExists. repeat (eauto; econstructor). - simpl. subst. reflexivity. - - TrivialExists. -Qed. - -Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v). -Proof. - red; intros until x. unfold negint. case (negint_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_shlimm: - forall n, unary_constructor_sound (fun a => shlimm a n) - (fun x => Val.shl x (Vint n)). -Proof. - red; intros until x. unfold shlimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto. - - destruct (Int.ltu n Int.iwordsize) eqn:LT; simpl. - destruct (shlimm_match a); intros; InvEval. - - exists (Vint (Int.shl n1 n)); split. EvalOp. - simpl. rewrite LT. auto. - - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - + exists (Val.shl v1 (Vint (Int.add n n1))); split. EvalOp. - subst. destruct v1; simpl; auto. - rewrite Heqb. - destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. - destruct (Int.ltu n Int.iwordsize) eqn:?; simpl; auto. - rewrite Int.add_commut. rewrite Int.shl_shl; auto. rewrite Int.add_commut; auto. - + subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. - simpl. auto. - - TrivialExists. - - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. - auto. -Qed. - -Theorem eval_shruimm: - forall n, unary_constructor_sound (fun a => shruimm a n) - (fun x => Val.shru x (Vint n)). -Proof. - red; intros until x. unfold shruimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto. - - destruct (Int.ltu n Int.iwordsize) eqn:LT. - destruct (shruimm_match a); intros; InvEval. - - exists (Vint (Int.shru n1 n)); split. EvalOp. - simpl. rewrite LT; auto. - - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - exists (Val.shru v1 (Vint (Int.add n n1))); split. EvalOp. - subst. destruct v1; simpl; auto. - rewrite Heqb. - destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. - rewrite LT. rewrite Int.add_commut. rewrite Int.shru_shru; auto. rewrite Int.add_commut; auto. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. - simpl. auto. - - subst x. - simpl negb. - cbn iota. - destruct (is_bitfield _ _) eqn:BOUNDS. - + exists (extfz (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize) v1). - split. - ++ EvalOp. - ++ unfold extfz. - rewrite BOUNDS. - destruct v1; try (simpl; apply Val.lessdef_undef). - replace (Z.sub Int.zwordsize - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. - replace (Z.sub Int.zwordsize - (Z.sub - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. - rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - simpl. - destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. - simpl. - destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. - + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - - TrivialExists. - - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. - auto. -Qed. - -Theorem eval_shrimm: - forall n, unary_constructor_sound (fun a => shrimm a n) - (fun x => Val.shr x (Vint n)). -Proof. - red; intros until x. unfold shrimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto. - - destruct (Int.ltu n Int.iwordsize) eqn:LT. - destruct (shrimm_match a); intros; InvEval. - - exists (Vint (Int.shr n1 n)); split. EvalOp. - simpl. rewrite LT; auto. - - destruct (Int.ltu (Int.add n n1) Int.iwordsize) eqn:?. - exists (Val.shr v1 (Vint (Int.add n n1))); split. EvalOp. - subst. destruct v1; simpl; auto. - rewrite Heqb. - destruct (Int.ltu n1 Int.iwordsize) eqn:?; simpl; auto. - rewrite LT. - rewrite Int.add_commut. rewrite Int.shr_shr; auto. rewrite Int.add_commut; auto. - subst. TrivialExists. econstructor. EvalOp. simpl; eauto. constructor. - simpl. auto. - - subst x. - simpl negb. - cbn iota. - destruct (is_bitfield _ _) eqn:BOUNDS. - + exists (extfs (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize) v1). - split. - ++ EvalOp. - ++ unfold extfs. - rewrite BOUNDS. - destruct v1; try (simpl; apply Val.lessdef_undef). - replace (Z.sub Int.zwordsize - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one)) with (Int.unsigned n1) by omega. - replace (Z.sub Int.zwordsize - (Z.sub - (Z.add (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one)) Z.one) - (Z.sub - (Z.add - (Z.add (Int.unsigned n) (Z.sub Int.zwordsize (Z.add (Int.unsigned n1) Z.one))) - Z.one) Int.zwordsize))) with (Int.unsigned n) by omega. - rewrite Int.repr_unsigned. - rewrite Int.repr_unsigned. - simpl. - destruct (Int.ltu n1 Int.iwordsize) eqn:Hltu_n1; simpl; trivial. - simpl. - destruct (Int.ltu n Int.iwordsize) eqn:Hltu_n; simpl; trivial. - + TrivialExists. constructor. econstructor. constructor. eassumption. constructor. simpl. reflexivity. constructor. simpl. reflexivity. - - TrivialExists. - - intros; TrivialExists. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor. - auto. -Qed. - -Lemma eval_mulimm_base: - forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)). -Proof. - intros; red; intros; unfold mulimm_base. - - assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v). - TrivialExists. econstructor. EvalOp. simpl; eauto. econstructor. eauto. constructor. - rewrite Val.mul_commut. auto. - - generalize (Int.one_bits_decomp n). - generalize (Int.one_bits_range n). - destruct (Int.one_bits n). - - intros. TrivialExists. - - destruct l. - + intros. rewrite H1. simpl. - rewrite Int.add_zero. - replace (Vint (Int.shl Int.one i)) with (Val.shl Vone (Vint i)). rewrite Val.shl_mul. - apply eval_shlimm. auto. simpl. rewrite H0; auto with coqlib. - + destruct l. - intros. rewrite H1. simpl. - exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]]. - exploit (eval_shlimm i0 (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]]. - exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]]. - exists v; split. econstructor; eauto. - rewrite Int.add_zero. - replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one i0))) - with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint i0))). - rewrite Val.mul_add_distr_r. - repeat rewrite Val.shl_mul. eapply Val.lessdef_trans. 2: eauto. apply Val.add_lessdef; auto. - simpl. repeat rewrite H0; auto with coqlib. - intros. TrivialExists. -Qed. - -Theorem eval_mulimm: - forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)). -Proof. - intros; red; intros until x; unfold mulimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros. exists (Vint Int.zero); split. EvalOp. - destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto. - - predSpec Int.eq Int.eq_spec n Int.one. - intros. exists x; split; auto. - destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto. - - case (mulimm_match a); intros; InvEval. - - TrivialExists. simpl. rewrite Int.mul_commut; auto. - - subst. rewrite Val.mul_add_distr_l. - exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]]. - exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]]. - exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto. - rewrite Val.mul_commut; auto. - - apply eval_mulimm_base; auto. -Qed. - -Theorem eval_mul: binary_constructor_sound mul Val.mul. -Proof. - red; intros until y. - unfold mul; case (mul_match a b); intros; InvEval. - rewrite Val.mul_commut. apply eval_mulimm. auto. - apply eval_mulimm. auto. - TrivialExists. -Qed. - -Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs. -Proof. - red; intros. unfold mulhs; destruct Archi.ptr64 eqn:SF. -- econstructor; split. - EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. - constructor. EvalOp. simpl; eauto. constructor. - simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. - destruct x; simpl; auto. destruct y; simpl; auto. - change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. - apply Val.lessdef_same. f_equal. - transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)). - unfold Int.mulhs; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. - apply Int.same_bits_eq; intros n N. - change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. - rewrite Int64.bits_loword by auto. - rewrite Int64.bits_shr' by auto. - change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. - rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). - transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. - apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. -- TrivialExists. -Qed. - -Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu. -Proof. - red; intros. unfold mulhu; destruct Archi.ptr64 eqn:SF. -- econstructor; split. - EvalOp. constructor. EvalOp. constructor. EvalOp. constructor. EvalOp. simpl; eauto. - constructor. EvalOp. simpl; eauto. constructor. - simpl; eauto. constructor. simpl; eauto. constructor. simpl; eauto. - destruct x; simpl; auto. destruct y; simpl; auto. - change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl. - apply Val.lessdef_same. f_equal. - transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)). - unfold Int.mulhu; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity. - apply Int.same_bits_eq; intros n N. - change Int.zwordsize with 32 in *. - assert (N1: 0 <= n < 64) by omega. - rewrite Int64.bits_loword by auto. - rewrite Int64.bits_shru' by auto. - change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64. - rewrite zlt_true by omega. - rewrite Int.testbit_repr by auto. - unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega). - transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)). - rewrite Z.shiftr_spec by omega. auto. - apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr. - change Int64.zwordsize with 64; omega. -- TrivialExists. -Qed. - -Theorem eval_andimm: - forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)). -Proof. - intros; red; intros until x. unfold andimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros. exists (Vint Int.zero); split. EvalOp. - destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto. - - predSpec Int.eq Int.eq_spec n Int.mone. - intros. exists x; split; auto. - subst. destruct x; simpl; auto. rewrite Int.and_mone; auto. - - case (andimm_match a); intros. - - InvEval. TrivialExists. simpl. rewrite Int.and_commut; auto. - - InvEval. subst. rewrite Val.and_assoc. simpl. rewrite Int.and_commut. TrivialExists. - - InvEval. TrivialExists. simpl; congruence. - - TrivialExists. -Qed. - -Theorem eval_and: binary_constructor_sound and Val.and. -Proof. - red; intros until y; unfold and; case (and_match a b); intros; InvEval. - - rewrite Val.and_commut. apply eval_andimm; auto. - - apply eval_andimm; auto. - - (*andn*) TrivialExists; simpl; congruence. - - (*andn reverse*) rewrite Val.and_commut. TrivialExists; simpl; congruence. - - TrivialExists. -Qed. - -Theorem eval_orimm: - forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)). -Proof. - intros; red; intros until x. unfold orimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - intros. subst. exists x; split; auto. - destruct x; simpl; auto. rewrite Int.or_zero; auto. - - predSpec Int.eq Int.eq_spec n Int.mone. - intros. exists (Vint Int.mone); split. EvalOp. - destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto. - - destruct (orimm_match a); intros; InvEval. - - TrivialExists. simpl. rewrite Int.or_commut; auto. - - subst. rewrite Val.or_assoc. simpl. rewrite Int.or_commut. TrivialExists. - - InvEval. TrivialExists. simpl; congruence. - - TrivialExists. -Qed. - - -Remark eval_same_expr: - forall a1 a2 le v1 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - a1 = a2 /\ v1 = v2. -Proof. - intros until v2. - destruct a1; simpl; try (intros; discriminate). - destruct a2; simpl; try (intros; discriminate). - case (ident_eq i i0); intros. - subst i0. inversion H0. inversion H1. split. auto. congruence. - discriminate. -Qed. - -Lemma int_eq_commut: forall x y : int, - (Int.eq x y) = (Int.eq y x). -Proof. - intros. - predSpec Int.eq Int.eq_spec x y; - predSpec Int.eq Int.eq_spec y x; - congruence. -Qed. - -Theorem eval_or: binary_constructor_sound or Val.or. -Proof. - unfold or; red; intros. - assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oor (a:::b:::Enil)) v /\ Val.lessdef (Val.or x y) v) by TrivialExists. - assert (ROR: forall v n1 n2, - Int.add n1 n2 = Int.iwordsize -> - Val.lessdef (Val.or (Val.shl v (Vint n1)) (Val.shru v (Vint n2))) - (Val.ror v (Vint n2))). - { intros. destruct v; simpl; auto. - destruct (Int.ltu n1 Int.iwordsize) eqn:N1; auto. - destruct (Int.ltu n2 Int.iwordsize) eqn:N2; auto. - simpl. rewrite <- Int.or_ror; auto. } - - destruct (or_match a b); InvEval. - - - rewrite Val.or_commut. apply eval_orimm; auto. - - apply eval_orimm; auto. - - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. - destruct (same_expr_pure t1 t2) eqn:?; auto. - InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. - exists (Val.ror v0 (Vint n2)); split. EvalOp. apply ROR; auto. - - predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int.iwordsize; auto. - destruct (same_expr_pure t1 t2) eqn:?; auto. - InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst. - exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto. - - (*orn*) TrivialExists; simpl; congruence. - - (*orn reversed*) rewrite Val.or_commut. TrivialExists; simpl; congruence. - - set (zstop := (int_highest_bit mask)). - set (zstart := (Int.unsigned start)). - destruct (is_bitfield _ _) eqn:Risbitfield. - + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. - * simpl in H6. - injection H6. - clear H6. - intro. subst y. subst x. - TrivialExists. simpl. f_equal. - unfold insf. - rewrite Risbitfield. - rewrite Rmask. - rewrite Rnmask. - simpl. - unfold bitfield_mask. - subst v0. - subst zstart. - rewrite Int.repr_unsigned. - reflexivity. - * apply DEFAULT. - + apply DEFAULT. - - set (zstop := (int_highest_bit mask)). - set (zstart := 0). - destruct (is_bitfield _ _) eqn:Risbitfield. - + destruct (and_dec _ _) as [[Rmask Rnmask] | ]. - * subst y. subst x. - TrivialExists. simpl. f_equal. - unfold insf. - rewrite Risbitfield. - rewrite Rmask. - rewrite Rnmask. - simpl. - unfold bitfield_mask. - subst zstart. - rewrite (Val.or_commut (Val.and v1 _)). - rewrite (Val.or_commut (Val.and v1 _)). - destruct v0; simpl; trivial. - unfold Int.ltu, Int.iwordsize, Int.zwordsize. - rewrite Int.unsigned_repr. - ** rewrite Int.unsigned_repr. - *** simpl. - rewrite Int.shl_zero. - reflexivity. - *** simpl. - unfold Int.max_unsigned, Int.modulus. - simpl. - omega. - ** unfold Int.max_unsigned, Int.modulus. - simpl. - omega. - * apply DEFAULT. - + apply DEFAULT. - - apply DEFAULT. -Qed. - -Theorem eval_xorimm: - forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)). -Proof. - intros; red; intros until x. unfold xorimm. - - predSpec Int.eq Int.eq_spec n Int.zero. - - intros. exists x; split. auto. - destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto. - - predSpec Int.eq Int.eq_spec n Int.mone. - -- subst n. intros. rewrite <- Val.not_xor. TrivialExists. - -- intros. destruct (xorimm_match a); intros; InvEval. - + TrivialExists. simpl. rewrite Int.xor_commut; auto. - + subst. rewrite Val.xor_assoc. simpl. rewrite Int.xor_commut. - predSpec Int.eq Int.eq_spec (Int.xor n2 n) Int.zero. - * exists v1; split; auto. destruct v1; simpl; auto. rewrite H1, Int.xor_zero; auto. - * TrivialExists. - + TrivialExists. -Qed. - -Theorem eval_xor: binary_constructor_sound xor Val.xor. -Proof. - red; intros until y; unfold xor; case (xor_match a b); intros; InvEval. - - rewrite Val.xor_commut. apply eval_xorimm; auto. - - apply eval_xorimm; auto. - - TrivialExists. -Qed. - -Theorem eval_notint: unary_constructor_sound notint Val.notint. -Proof. - assert (forall v, Val.lessdef (Val.notint (Val.notint v)) v). - destruct v; simpl; auto. rewrite Int.not_involutive; auto. - unfold notint; red; intros until x; case (notint_match a); intros; InvEval. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - TrivialExists; simpl; congruence. - - subst x. exists (Val.and v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.and v1 (Vint n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - - subst x. exists (Val.or v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.or v1 (Vint n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - - subst x. exists (Val.xor v1 v0); split; trivial. - econstructor. constructor. eassumption. constructor. - eassumption. constructor. simpl. reflexivity. - - subst x. exists (Val.xor v1 (Vint n)); split; trivial. - econstructor. constructor. eassumption. constructor. - simpl. reflexivity. - (* andn *) - - subst x. TrivialExists. simpl. - destruct v0; destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int.not_and_or_not. - rewrite Int.not_involutive. - apply Int.or_commut. - - subst x. TrivialExists. simpl. - destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int.not_and_or_not. - rewrite Int.not_involutive. - reflexivity. - (* orn *) - - subst x. TrivialExists. simpl. - destruct v0; destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int.not_or_and_not. - rewrite Int.not_involutive. - apply Int.and_commut. - - subst x. TrivialExists. simpl. - destruct v1; simpl; trivial. - f_equal. f_equal. - rewrite Int.not_or_and_not. - rewrite Int.not_involutive. - reflexivity. - - subst x. exists v1; split; trivial. - - TrivialExists. - - TrivialExists. -Qed. - -Theorem eval_divs_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.divs x y = Some z -> - exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v. -Proof. - intros; unfold divs_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - -Theorem eval_mods_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.mods x y = Some z -> - exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v. -Proof. - intros; unfold mods_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - -Theorem eval_divu_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.divu x y = Some z -> - exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v. -Proof. - intros; unfold divu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - -(* For using 64-bit unsigned division for 32-bit - - intros until z. - intros Hax Hby Hdiv. unfold divu_base. - pose proof (divu_is_divlu x y) as DIVU. - destruct (Val.divlu (Val.longofintu x) (Val.longofintu y)) - as [ ql | ] eqn:Ediv. - { TrivialExists. - { econstructor. eapply eval_helper_2; eauto. - { econstructor. econstructor. eassumption. - constructor. simpl. reflexivity. } - { econstructor. econstructor. eassumption. - constructor. simpl. reflexivity. } - { DeclHelper. } - { UseHelper. } - constructor. } - simpl. - congruence. - } - congruence. -Qed. - *) - -Theorem eval_modu_base: - forall le a b x y z, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - Val.modu x y = Some z -> - exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v. -Proof. - intros; unfold modu_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - -(* for using 64-bit unsigned modulo for 32-bit - - intros until z. - intros Hax Hby Hmod. unfold modu_base. - pose proof (modu_is_modlu x y) as MODU. - destruct (Val.modlu (Val.longofintu x) (Val.longofintu y)) - as [ ql | ] eqn:Emod. - { TrivialExists. - { econstructor. eapply eval_helper_2; eauto. - { econstructor. econstructor. eassumption. - constructor. simpl. reflexivity. } - { econstructor. econstructor. eassumption. - constructor. simpl. reflexivity. } - { DeclHelper. } - { UseHelper. } - constructor. } - simpl. - congruence. - } - congruence. -Qed. - *) - -Theorem eval_shrximm: - forall le a n x z, - eval_expr ge sp e m le a x -> - Val.shrx x (Vint n) = Some z -> - exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v. -Proof. - intros. unfold shrximm. - predSpec Int.eq Int.eq_spec n Int.zero. - subst n. exists x; split; auto. - destruct x; simpl in H0; try discriminate. - destruct (Int.ltu Int.zero (Int.repr 31)); inv H0. - replace (Int.shrx i Int.zero) with i. auto. - unfold Int.shrx, Int.divs. rewrite Int.shl_zero. - change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed; auto. - econstructor; split. EvalOp. - simpl. rewrite H0. simpl. reflexivity. auto. -Qed. - -Theorem eval_shl: binary_constructor_sound shl Val.shl. -Proof. - red; intros until y; unfold shl; case (shl_match b); intros. - InvEval. apply eval_shlimm; auto. - TrivialExists. -Qed. - -Theorem eval_shr: binary_constructor_sound shr Val.shr. -Proof. - red; intros until y; unfold shr; case (shr_match b); intros. - InvEval. apply eval_shrimm; auto. - TrivialExists. -Qed. - -Theorem eval_shru: binary_constructor_sound shru Val.shru. -Proof. - red; intros until y; unfold shru; case (shru_match b); intros. - InvEval. apply eval_shruimm; auto. - TrivialExists. -Qed. - -Theorem eval_negf: unary_constructor_sound negf Val.negf. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_absf: unary_constructor_sound absf Val.absf. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_addf: binary_constructor_sound addf Val.addf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_subf: binary_constructor_sound subf Val.subf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_mulf: binary_constructor_sound mulf Val.mulf. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_negfs: unary_constructor_sound negfs Val.negfs. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_absfs: unary_constructor_sound absfs Val.absfs. -Proof. - red; intros. TrivialExists. -Qed. - -Theorem eval_addfs: binary_constructor_sound addfs Val.addfs. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_subfs: binary_constructor_sound subfs Val.subfs. -Proof. - red; intros; TrivialExists. -Qed. - -Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs. -Proof. - red; intros; TrivialExists. -Qed. - -Section COMP_IMM. - -Variable default: comparison -> int -> condition. -Variable intsem: comparison -> int -> int -> bool. -Variable sem: comparison -> val -> val -> val. - -Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y). -Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef. -Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y). -Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)). -Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m). - -Lemma eval_compimm: - forall le c a n2 x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v - /\ Val.lessdef (sem c x (Vint n2)) v. -Proof. - intros until x. - unfold compimm; case (compimm_match c a); intros. -(* constant *) - - InvEval. rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto. -(* eq cmp *) - - InvEval. inv H. simpl in H5. inv H5. - destruct (Int.eq_dec n2 Int.zero). - + subst n2. TrivialExists. - simpl. rewrite eval_negate_condition. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. - rewrite sem_undef; auto. - + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. - simpl. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto. - rewrite sem_undef; auto. - exists (Vint Int.zero); split. EvalOp. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto. - rewrite sem_undef; auto. -(* ne cmp *) - - InvEval. inv H. simpl in H5. inv H5. - destruct (Int.eq_dec n2 Int.zero). - + subst n2. TrivialExists. - simpl. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. - rewrite sem_undef; auto. - + destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists. - simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto. - rewrite sem_undef; auto. - exists (Vint Int.one); split. EvalOp. - destruct (eval_condition c0 vl m); simpl. - unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto. - rewrite sem_undef; auto. -(* default *) - - TrivialExists. simpl. rewrite sem_default. auto. -Qed. - -Hypothesis sem_swap: - forall c x y, sem (swap_comparison c) x y = sem c y x. - -Lemma eval_compimm_swap: - forall le c a n2 x, - eval_expr ge sp e m le a x -> - exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v - /\ Val.lessdef (sem c (Vint n2) x) v. -Proof. - intros. rewrite <- sem_swap. eapply eval_compimm; eauto. -Qed. - -End COMP_IMM. - -Theorem eval_comp: - forall c, binary_constructor_sound (comp c) (Val.cmp c). -Proof. - intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval. - eapply eval_compimm_swap; eauto. - intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto. - eapply eval_compimm; eauto. - TrivialExists. -Qed. - -Theorem eval_compu: - forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c). -Proof. - intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval. - eapply eval_compimm_swap; eauto. - intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto. - eapply eval_compimm; eauto. - TrivialExists. -Qed. - -Theorem eval_compf: - forall c, binary_constructor_sound (compf c) (Val.cmpf c). -Proof. - intros; red; intros. unfold compf. TrivialExists. -Qed. - -Theorem eval_compfs: - forall c, binary_constructor_sound (compfs c) (Val.cmpfs c). -Proof. - intros; red; intros. unfold compfs. TrivialExists. -Qed. - -Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8). -Proof. - red; intros until x. unfold cast8signed. case (cast8signed_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8). -Proof. - red; intros until x. unfold cast8unsigned. - - rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. -Qed. - -Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16). -Proof. - red; intros until x. unfold cast16signed. case (cast16signed_match a); intros; InvEval. - TrivialExists. - TrivialExists. -Qed. - -Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16). -Proof. - red; intros until x. unfold cast8unsigned. - rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate. -Qed. - -Theorem eval_intoffloat: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intoffloat x = Some y -> - exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v. -Proof. - intros; unfold intoffloat. TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_intuoffloat: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intuoffloat x = Some y -> - exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v. -Proof. - intros; unfold intuoffloat. TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_floatofintu: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.floatofintu x = Some y -> - exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v. -Proof. - intros. - unfold Val.floatofintu in *. - unfold floatofintu. - destruct (floatofintu_match a). - - InvEval. - TrivialExists. - - InvEval. - TrivialExists. - constructor. econstructor. constructor. eassumption. constructor. - simpl. f_equal. constructor. - simpl. - destruct x; simpl; trivial; try discriminate. - f_equal. - inv H0. - f_equal. - rewrite Float.of_intu_of_longu. - reflexivity. -Qed. - -Theorem eval_floatofint: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.floatofint x = Some y -> - exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v. -Proof. - intros. - unfold floatofint. - destruct (floatofint_match a). - - InvEval. - TrivialExists. - - InvEval. - TrivialExists. - constructor. econstructor. constructor. eassumption. constructor. - simpl. f_equal. constructor. - simpl. - destruct x; simpl; trivial; try discriminate. - f_equal. - inv H0. - f_equal. - rewrite Float.of_int_of_long. - reflexivity. -Qed. - -Theorem eval_intofsingle: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intofsingle x = Some y -> - exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v. -Proof. - intros; unfold intofsingle. TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_singleofint: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.singleofint x = Some y -> - exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v. -Proof. - intros; unfold singleofint; TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_intuofsingle: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.intuofsingle x = Some y -> - exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v. -Proof. - intros; unfold intuofsingle. TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_singleofintu: - forall le a x y, - eval_expr ge sp e m le a x -> - Val.singleofintu x = Some y -> - exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v. -Proof. - intros; unfold intuofsingle. TrivialExists. - simpl. rewrite H0. reflexivity. -Qed. - -Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat. -Proof. - red; intros. unfold singleoffloat. TrivialExists. -Qed. - -Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle. -Proof. - red; intros. unfold floatofsingle. TrivialExists. -Qed. - -Theorem eval_addressing: - forall le chunk a v b ofs, - eval_expr ge sp e m le a v -> - v = Vptr b ofs -> - match addressing chunk a with (mode, args) => - exists vl, - eval_exprlist ge sp e m le args vl /\ - eval_addressing ge sp mode vl = Some v - end. -Proof. - intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - - exists (@nil val); split. eauto with evalexpr. simpl. auto. - - destruct (orb _ _). - + exists (Vptr b ofs0 :: nil); split. - constructor. EvalOp. simpl. congruence. constructor. simpl. rewrite Ptrofs.add_zero. congruence. - + exists (@nil val); split. constructor. simpl; auto. - - exists (v1 :: nil); split. eauto with evalexpr. simpl. - destruct v1; simpl in H; try discriminate. - - exists (v1 :: nil); split. eauto with evalexpr. simpl. - destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H. - simpl. auto. - - destruct (Compopts.optim_xsaddr tt). - + destruct (Z.eq_dec _ _). - * exists (v1 :: v2 :: nil); split. - repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence. - * exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. - simpl. congruence. - + exists (v1 :: v0 :: nil); split. - repeat (constructor; auto). econstructor. - repeat (constructor; auto). eassumption. simpl. congruence. - simpl. congruence. - - unfold addxl in *. - destruct (Compopts.optim_xsaddr tt). - + unfold int_of_shift1_4 in *. - destruct (Z.eq_dec _ _). - * exists (v0 :: v1 :: nil); split. - repeat (constructor; auto). simpl. - congruence. - * eexists; split. - repeat (constructor; auto). eassumption. - econstructor. - repeat (constructor; auto). eassumption. simpl. - reflexivity. - simpl. congruence. - + eexists; split. - repeat (constructor; auto). eassumption. - econstructor. - repeat (constructor; auto). eassumption. simpl. - reflexivity. - simpl. unfold int_of_shift1_4 in *. congruence. - - exists (v1 :: v0 :: nil); split. repeat (constructor; auto). simpl. congruence. - - exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto. -Qed. - -Theorem eval_builtin_arg: - forall a v, - eval_expr ge sp e m nil a v -> - CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v. -Proof. - intros until v. unfold builtin_arg; case (builtin_arg_match a); intros. -- InvEval. constructor. -- InvEval. constructor. -- InvEval. constructor. -- InvEval. simpl in H5. inv H5. constructor. -- InvEval. subst v. constructor; auto. -- inv H. InvEval. simpl in H6; inv H6. constructor; auto. -- destruct Archi.ptr64 eqn:SF. -+ constructor; auto. -+ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vint n) else Val.add v1 (Vint n)). - repeat constructor; auto. - rewrite SF; auto. -- destruct Archi.ptr64 eqn:SF. -+ InvEval. replace v with (if Archi.ptr64 then Val.addl v1 (Vlong n) else Val.add v1 (Vlong n)). - repeat constructor; auto. -+ constructor; auto. -- constructor; auto. -Qed. - -(* ternary *) -(* does not work due to possible nondeterminism -Lemma cond_to_condition0_correct : - forall cond : condition, - forall al : exprlist, - match (cond_to_condition0 cond al) with - | None => True - | Some(cond0, e1) => - forall le vl v1, - eval_expr ge sp e m le e1 v1 -> - eval_exprlist ge sp e m le al vl -> - (eval_condition0 cond0 v1 m) = (eval_condition cond vl m) - end. -Proof. - intros. - unfold cond_to_condition0. - case (cond_to_condition0_match cond al); trivial. - { - intros. - destruct (Int.eq_dec _ _); trivial. - intros until v1. - intros He1 Hel. - InvEval. - simpl. - f_equal. - eapply eval_expr_determ. eassumption. - } -Qed. -*) - -Lemma eval_neg_condition0: - forall cond0: condition0, - forall v1: val, - forall m: mem, - (eval_condition0 (negate_condition0 cond0) v1 m) = - option_map negb (eval_condition0 cond0 v1 m). -Proof. - intros. - destruct cond0; simpl; - try rewrite Val.negate_cmp_bool; - try rewrite Val.negate_cmpu_bool; - try rewrite Val.negate_cmpl_bool; - try rewrite Val.negate_cmplu_bool; - reflexivity. -Qed. - -Lemma select_neg: - forall a b c, - Val.select (option_map negb a) b c = - Val.select a c b. -Proof. - destruct a; simpl; trivial. - destruct b; simpl; trivial. -Qed. - -Lemma eval_select0: - forall le ty cond0 ac vc a1 v1 a2 v2, - eval_expr ge sp e m le ac vc -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - exists v, - eval_expr ge sp e m le (select0 ty cond0 a1 a2 ac) v - /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v. -Proof. - intros. - unfold select0. - destruct (select0_match ty cond0 a1 a2 ac). - all: InvEval; econstructor; split; - try repeat (try econstructor; try eassumption). - all: rewrite eval_neg_condition0; rewrite select_neg; constructor. -Qed. - -Lemma bool_cond0_ne: - forall ob : option bool, - forall m, - (eval_condition0 (Ccomp0 Cne) (Val.of_optbool ob) m) = ob. -Proof. - destruct ob; simpl; trivial. - intro. - destruct b; reflexivity. -Qed. - -Lemma eval_condition_ccomp_swap : - forall c x y m, - eval_condition (Ccomp (swap_comparison c)) (x :: y :: nil) m= - eval_condition (Ccomp c) (y :: x :: nil) m. -Proof. - intros; unfold eval_condition; - apply Val.swap_cmp_bool. -Qed. - -Lemma eval_condition_ccompu_swap : - forall c x y m, - eval_condition (Ccompu (swap_comparison c)) (x :: y :: nil) m= - eval_condition (Ccompu c) (y :: x :: nil) m. -Proof. - intros; unfold eval_condition; - apply Val.swap_cmpu_bool. -Qed. - -Lemma eval_condition_ccompl_swap : - forall c x y m, - eval_condition (Ccompl (swap_comparison c)) (x :: y :: nil) m= - eval_condition (Ccompl c) (y :: x :: nil) m. -Proof. - intros; unfold eval_condition; - apply Val.swap_cmpl_bool. -Qed. - -Lemma eval_condition_ccomplu_swap : - forall c x y m, - eval_condition (Ccomplu (swap_comparison c)) (x :: y :: nil) m= - eval_condition (Ccomplu c) (y :: x :: nil) m. -Proof. - intros; unfold eval_condition; - apply Val.swap_cmplu_bool. -Qed. - -Theorem eval_select: - forall le ty cond al vl a1 v1 a2 v2 a b, - select ty cond al a1 a2 = Some a -> - eval_exprlist ge sp e m le al vl -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - eval_condition cond vl m = Some b -> - exists v, - eval_expr ge sp e m le a v - /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v. -Proof. - unfold select. - intros until b. - intro Hop; injection Hop; clear Hop; intro; subst a. - intros HeL He1 He2 HeC. - unfold cond_to_condition0. - destruct (cond_to_condition0_match cond al). - { - InvEval. - rewrite <- HeC. - destruct (Int.eq_dec x Int.zero). - { subst x. - simpl. - change (Val.cmp_bool c v0 (Vint Int.zero)) - with (eval_condition0 (Ccomp0 c) v0 m). - eapply eval_select0; eassumption. - } - simpl. - erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))). - eapply eval_select0; repeat (try econstructor; try eassumption). - } - { - InvEval. - rewrite <- HeC. - destruct (Int.eq_dec x Int.zero). - { subst x. - simpl. - change (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint Int.zero)) - with (eval_condition0 (Ccompu0 c) v0 m). - eapply eval_select0; eassumption. - } - simpl. - erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))). - eapply eval_select0; repeat (try econstructor; try eassumption). - } - { - InvEval. - rewrite <- HeC. - destruct (Int64.eq_dec x Int64.zero). - { subst x. - simpl. - change (Val.cmpl_bool c v0 (Vlong Int64.zero)) - with (eval_condition0 (Ccompl0 c) v0 m). - eapply eval_select0; eassumption. - } - simpl. - erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))). - eapply eval_select0; repeat (try econstructor; try eassumption). - } - { - InvEval. - rewrite <- HeC. - destruct (Int64.eq_dec x Int64.zero). - { subst x. - simpl. - change (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong Int64.zero)) - with (eval_condition0 (Ccomplu0 c) v0 m). - eapply eval_select0; eassumption. - } - simpl. - erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))). - eapply eval_select0; repeat (try econstructor; try eassumption). - } - erewrite <- (bool_cond0_ne (Some b)). - eapply eval_select0; repeat (try econstructor; try eassumption). - rewrite <- HeC. - simpl. - reflexivity. -Qed. - -(* floating-point division *) -Theorem eval_divf_base: - forall le a b x y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (divf_base a b) v /\ Val.lessdef (Val.divf x y) v. -Proof. - intros; unfold divf_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - - -Lemma eval_divfs_base1: - forall le a b x y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (divfs_base1 b) v /\ Val.lessdef (ExtValues.invfs y) v. -Proof. - intros; unfold divfs_base1. - econstructor; split. - repeat (try econstructor; try eassumption). - trivial. -Qed. - -Lemma eval_divfs_baseX: - forall le a b x y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (divfs_baseX a b) v /\ Val.lessdef (Val.divfs x y) v. -Proof. - intros; unfold divfs_base. - econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto. -Qed. - -Theorem eval_divfs_base: - forall le a b x y, - eval_expr ge sp e m le a x -> - eval_expr ge sp e m le b y -> - exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v. -Proof. - intros; unfold divfs_base. - destruct (divfs_base_match _). - - destruct (Float32.eq_dec _ _). - + exists (Val.divfs x y). - split; trivial. repeat (try econstructor; try eassumption). - simpl. InvEval. reflexivity. - + apply eval_divfs_baseX; assumption. - - apply eval_divfs_baseX; assumption. -Qed. - -(** Platform-specific known builtins *) - -Lemma eval_fma: - forall al a vl v le, - gen_fma al = Some a -> - eval_exprlist ge sp e m le al vl -> - platform_builtin_sem BI_fma vl = Some v -> - exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. -Proof. - unfold gen_fma. - intros until le. - intro Heval. - destruct (gen_fma_match _) in *; try discriminate. - all: inversion Heval; subst a; clear Heval; intro; InvEval. - - subst v1. - TrivialExists. - destruct v0; simpl; trivial; - destruct v2; simpl; trivial; - destruct v3; simpl; trivial. - - intro Heval. - simpl in Heval. - inv Heval. - TrivialExists. - destruct v0; simpl; trivial; - destruct v1; simpl; trivial; - destruct v2; simpl; trivial. -Qed. - -Lemma eval_fmaf: - forall al a vl v le, - gen_fmaf al = Some a -> - eval_exprlist ge sp e m le al vl -> - platform_builtin_sem BI_fmaf vl = Some v -> - exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. -Proof. - unfold gen_fmaf. - intros until le. - intro Heval. - destruct (gen_fmaf_match _) in *; try discriminate. - all: inversion Heval; subst a; clear Heval; intro; InvEval. - - subst v1. - TrivialExists. - destruct v0; simpl; trivial; - destruct v2; simpl; trivial; - destruct v3; simpl; trivial. - - intro Heval. - simpl in Heval. - inv Heval. - TrivialExists. - destruct v0; simpl; trivial; - destruct v1; simpl; trivial; - destruct v2; simpl; trivial. -Qed. - -Theorem eval_platform_builtin: - forall bf al a vl v le, - platform_builtin bf al = Some a -> - eval_exprlist ge sp e m le al vl -> - platform_builtin_sem bf vl = Some v -> - exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'. -Proof. - destruct bf; intros until le; intro Heval. - all: try (inversion Heval; subst a; clear Heval; - exists v; split; trivial; - repeat (try econstructor; try eassumption)). - - apply eval_fma; assumption. - - apply eval_fmaf; assumption. -Qed. - -End CMCONSTR. diff --git a/mppa_k1c/Stacklayout.v b/mppa_k1c/Stacklayout.v deleted file mode 100644 index 46202e03..00000000 --- a/mppa_k1c/Stacklayout.v +++ /dev/null @@ -1,150 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Machine- and ABI-dependent layout information for activation records. *) - -Require Import Coqlib. -Require Import AST Memory Separation. -Require Import Bounds. - -Local Open Scope sep_scope. - -(** The general shape of activation records is as follows, - from bottom (lowest offsets) to top: -- Space for outgoing arguments to function calls. -- Back link to parent frame -- Return address -- Saved values of callee-save registers used by the function. -- Local stack slots. -- Space for the stack-allocated data declared in Cminor. - -The stack pointer is kept 16-aligned. -*) - -Definition fe_ofs_arg := 0. - -Definition make_env (b: bounds) : frame_env := - let w := if Archi.ptr64 then 8 else 4 in - let olink := align (4 * b.(bound_outgoing)) w in (* back link *) - let oretaddr := olink + w in (* return address *) - let ocs := oretaddr + w in (* callee-saves *) - let ol := align (size_callee_save_area b ocs) 8 in (* locals *) - let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *) - let sz := align (ostkdata + b.(bound_stack_data)) 16 in - {| fe_size := sz; - fe_ofs_link := olink; - fe_ofs_retaddr := oretaddr; - fe_ofs_local := ol; - fe_ofs_callee_save := ocs; - fe_stack_data := ostkdata; - fe_used_callee_save := b.(used_callee_save) |}. - -Lemma frame_env_separated: - forall b sp m P, - let fe := make_env b in - m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P -> - m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b) - ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b) - ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr) - ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr) - ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe)) - ** P. -Proof. -Local Opaque Z.add Z.mul sepconj range. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (oretaddr := olink + w). - set (ocs := oretaddr + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + w <= ocs) by (unfold ocs; omega). - assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). -(* Reorder as: - outgoing - back link - retaddr - callee-save - local *) - rewrite sep_swap12. - rewrite sep_swap23. - rewrite sep_swap34. - rewrite sep_swap45. -(* Apply range_split and range_split2 repeatedly *) - unfold fe_ofs_arg. - apply range_split_2. fold olink; omega. omega. - apply range_split. omega. - apply range_split. omega. - apply range_split_2. fold ol. omega. omega. - apply range_drop_right with ostkdata. omega. - eapply sep_drop2. eexact H. -Qed. - -Lemma frame_env_range: - forall b, - let fe := make_env b in - 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe. -Proof. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (oretaddr := olink + w). - set (ocs := oretaddr + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros. - assert (0 <= 4 * b.(bound_outgoing)) by omega. - assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega). - assert (olink + w <= oretaddr) by (unfold oretaddr; omega). - assert (oretaddr + w <= ocs) by (unfold ocs; omega). - assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr). - assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega). - assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega). - split. omega. apply align_le. omega. -Qed. - -Lemma frame_env_aligned: - forall b, - let fe := make_env b in - (8 | fe_ofs_arg) - /\ (8 | fe_ofs_local fe) - /\ (8 | fe_stack_data fe) - /\ (align_chunk Mptr | fe_ofs_link fe) - /\ (align_chunk Mptr | fe_ofs_retaddr fe). -Proof. - intros; simpl. - set (w := if Archi.ptr64 then 8 else 4). - set (olink := align (4 * b.(bound_outgoing)) w). - set (oretaddr := olink + w). - set (ocs := oretaddr + w). - set (ol := align (size_callee_save_area b ocs) 8). - set (ostkdata := align (ol + 4 * b.(bound_local)) 8). - assert (0 < w) by (unfold w; destruct Archi.ptr64; omega). - replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto). - split. apply Z.divide_0_r. - split. apply align_divides; omega. - split. apply align_divides; omega. - split. apply align_divides; omega. - apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl. -Qed. diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml deleted file mode 100644 index e85b5ef3..00000000 --- a/mppa_k1c/TargetPrinter.ml +++ /dev/null @@ -1,887 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(* Printing RISC-V assembly code in asm syntax *) - -open Printf -open Camlcoq -open Sections -open AST -open Asm -open PrintAsmaux -open Fileinfo - -(* Module containing the printing functions *) - -module Target (*: TARGET*) = - struct - -(* Basic printing functions *) - - let comment = "#" - - type idiv_function_kind = - | Idiv_system - | Idiv_stsud - | Idiv_fp;; - - let idiv_function_kind = function - "stsud" -> Idiv_stsud - | "system" -> Idiv_system - | "fp" -> Idiv_fp - | _ -> failwith "unknown integer division kind";; - - let idiv_function_kind_32bit () = idiv_function_kind !Clflags.option_div_i32;; - let idiv_function_kind_64bit () = idiv_function_kind !Clflags.option_div_i64;; - - let subst_symbol = function - "__compcert_i64_udiv" -> - (match idiv_function_kind_64bit () with - | Idiv_system | Idiv_fp -> "__udivdi3" - | Idiv_stsud -> "__compcert_i64_udiv_stsud") - | "__compcert_i64_sdiv" -> - (match idiv_function_kind_64bit() with - | Idiv_system | Idiv_fp -> "__divdi3" - | Idiv_stsud -> "__compcert_i64_sdiv_stsud") - | "__compcert_i64_umod" -> - (match idiv_function_kind_64bit() with - | Idiv_system | Idiv_fp -> "__umoddi3" - | Idiv_stsud -> "__compcert_i64_umod_stsud") - | "__compcert_i64_smod" -> - (match idiv_function_kind_64bit() with - | Idiv_system | Idiv_fp -> "__moddi3" - | Idiv_stsud -> "__compcert_i64_smod_stsud") - | "__compcert_i32_sdiv" as s -> - (match idiv_function_kind_32bit() with - | Idiv_system -> s - | Idiv_fp -> "__compcert_i32_sdiv_fp" - | Idiv_stsud -> "__compcert_i32_sdiv_stsud") - | "__compcert_i32_udiv" as s -> - (match idiv_function_kind_32bit() with - | Idiv_system -> s - | Idiv_fp -> "__compcert_i32_udiv_fp" - | Idiv_stsud -> "__compcert_i32_udiv_stsud") - | "__compcert_i32_smod" as s -> - (match idiv_function_kind_32bit() with - | Idiv_system -> s - | Idiv_fp -> "__compcert_i32_smod_fp" - | Idiv_stsud -> "__compcert_i32_smod_stsud") - | "__compcert_i32_umod" as s -> - (match idiv_function_kind_32bit() with - | Idiv_system -> s - | Idiv_fp -> "__compcert_i32_umod_fp" - | Idiv_stsud -> "__compcert_i32_umod_stsud") - | "__compcert_f64_div" -> "__divdf3" - | "__compcert_f32_div" -> "__divsf3" - | x -> x;; - - let symbol oc symb = - fprintf oc "%s" (subst_symbol (extern_atom symb)) - - let symbol_offset oc (symb, ofs) = - symbol oc symb; - let ofs = camlint64_of_ptrofs ofs in - if ofs <> 0L then fprintf oc " + %Ld" ofs - - let label = elf_label - - let print_label oc lbl = label oc (transl_label lbl) - - let int_reg_name = let open Asmvliw in function - - | GPR0 -> "$r0" | GPR1 -> "$r1" | GPR2 -> "$r2" | GPR3 -> "$r3" - | GPR4 -> "$r4" | GPR5 -> "$r5" | GPR6 -> "$r6" | GPR7 -> "$r7" - | GPR8 -> "$r8" | GPR9 -> "$r9" | GPR10 -> "$r10" | GPR11 -> "$r11" - | GPR12 -> "$r12" | GPR13 -> "$r13" | GPR14 -> "$r14" | GPR15 -> "$r15" - | GPR16 -> "$r16" | GPR17 -> "$r17" | GPR18 -> "$r18" | GPR19 -> "$r19" - | GPR20 -> "$r20" | GPR21 -> "$r21" | GPR22 -> "$r22" | GPR23 -> "$r23" - | GPR24 -> "$r24" | GPR25 -> "$r25" | GPR26 -> "$r26" | GPR27 -> "$r27" - | GPR28 -> "$r28" | GPR29 -> "$r29" | GPR30 -> "$r30" | GPR31 -> "$r31" - | GPR32 -> "$r32" | GPR33 -> "$r33" | GPR34 -> "$r34" | GPR35 -> "$r35" - | GPR36 -> "$r36" | GPR37 -> "$r37" | GPR38 -> "$r38" | GPR39 -> "$r39" - | GPR40 -> "$r40" | GPR41 -> "$r41" | GPR42 -> "$r42" | GPR43 -> "$r43" - | GPR44 -> "$r44" | GPR45 -> "$r45" | GPR46 -> "$r46" | GPR47 -> "$r47" - | GPR48 -> "$r48" | GPR49 -> "$r49" | GPR50 -> "$r50" | GPR51 -> "$r51" - | GPR52 -> "$r52" | GPR53 -> "$r53" | GPR54 -> "$r54" | GPR55 -> "$r55" - | GPR56 -> "$r56" | GPR57 -> "$r57" | GPR58 -> "$r58" | GPR59 -> "$r59" - | GPR60 -> "$r60" | GPR61 -> "$r61" | GPR62 -> "$r62" | GPR63 -> "$r63" - - let ireg oc r = output_string oc (int_reg_name r) - - let int_gpreg_q_name = - let open Asmvliw in - function - | R0R1 -> "$r0r1" - | R2R3 -> "$r2r3" - | R4R5 -> "$r4r5" - | R6R7 -> "$r6r7" - | R8R9 -> "$r8r9" - | R10R11 -> "$r10r11" - | R12R13 -> "$r12r13" - | R14R15 -> "$r14r15" - | R16R17 -> "$r16r17" - | R18R19 -> "$r18r19" - | R20R21 -> "$r20r21" - | R22R23 -> "$r22r23" - | R24R25 -> "$r24r25" - | R26R27 -> "$r26r27" - | R28R29 -> "$r28r29" - | R30R31 -> "$r30r31" - | R32R33 -> "$r32r33" - | R34R35 -> "$r34r35" - | R36R37 -> "$r36r37" - | R38R39 -> "$r38r39" - | R40R41 -> "$r40r41" - | R42R43 -> "$r42r43" - | R44R45 -> "$r44r45" - | R46R47 -> "$r46r47" - | R48R49 -> "$r48r49" - | R50R51 -> "$r50r51" - | R52R53 -> "$r52r53" - | R54R55 -> "$r54r55" - | R56R57 -> "$r56r57" - | R58R59 -> "$r58r59" - | R60R61 -> "$r60r61" - | R62R63 -> "$r62r63" - - let int_gpreg_o_name = - let open Asmvliw in - function - | R0R1R2R3 -> "$r0r1r2r3" - | R4R5R6R7 -> "$r4r5r6r7" - | R8R9R10R11 -> "$r8r9r10r11" - | R12R13R14R15 -> "$r12r13r14r15" - | R16R17R18R19 -> "$r16r17r18r19" - | R20R21R22R23 -> "$r20r21r22r23" - | R24R25R26R27 -> "$r24r25r26r27" - | R28R29R30R31 -> "$r28r29r30r31" - | R32R33R34R35 -> "$r32r33r34r35" - | R36R37R38R39 -> "$r36r37r38r39" - | R40R41R42R43 -> "$r40r41r42r43" - | R44R45R46R47 -> "$r44r45r46r47" - | R48R49R50R51 -> "$r48r49r50r51" - | R52R53R54R55 -> "$r52r53r54r55" - | R56R57R58R59 -> "$r56r57r58r59" - | R60R61R62R63 -> "$r60r61r62r63";; - - let gpreg_q oc r = output_string oc (int_gpreg_q_name r) - let gpreg_o oc r = output_string oc (int_gpreg_o_name r) - - let preg oc = let open Asmvliw in function - | IR r -> ireg oc r - | RA -> output_string oc "$ra" - | _ -> assert false - - let preg_asm oc ty = preg oc - - let preg_annot = let open Asmvliw in function - | IR r -> int_reg_name r - | RA -> "$ra" - | _ -> assert false - - let scale_of_shift1_4 = let open ExtValues in function - | SHIFT1 -> 2 - | SHIFT2 -> 4 - | SHIFT3 -> 8 - | SHIFT4 -> 16;; - -(* Names of sections *) - - let name_of_section = function - | Section_text -> ".text" - | Section_data(true, true) -> - ".section .tdata,\"awT\",@progbits" - | Section_data(false, true) -> - ".section .tbss,\"awT\",@nobits" - | Section_data(i, false) | Section_small_data(i) -> - (if i then ".data" else "COMM") - | Section_const i | Section_small_const i -> - if i then ".section .rodata" else "COMM" - | Section_string -> ".section .rodata" - | Section_literal -> ".section .rodata" - | Section_jumptable -> ".section .rodata" - | Section_debug_info _ -> ".section .debug_info,\"\",%progbits" - | Section_debug_loc -> ".section .debug_loc,\"\",%progbits" - | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits" - | Section_debug_line _ -> ".section .debug_line,\"\",%progbits" - | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits" - | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1" - | Section_user(s, wr, ex) -> - sprintf ".section \"%s\",\"a%s%s\",%%progbits" - s (if wr then "w" else "") (if ex then "x" else "") - | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note" - - let section oc sec = - fprintf oc " %s\n" (name_of_section sec) - -(* Associate labels to floating-point constants and to symbols. *) - - let print_tbl oc (lbl, tbl) = - fprintf oc " .balign 8\n"; - fprintf oc "%a:\n" label lbl; - List.iter - (fun l -> fprintf oc " .8byte %a\n" - print_label l) - tbl - - let emit_constants oc lit = - if exists_constants () then begin - section oc lit; - if Hashtbl.length literal64_labels > 0 then - begin - fprintf oc " .align 3\n"; - Hashtbl.iter - (fun bf lbl -> fprintf oc "%a: .quad 0x%Lx\n" label lbl bf) - literal64_labels - end; - if Hashtbl.length literal32_labels > 0 then - begin - fprintf oc " .align 2\n"; - Hashtbl.iter - (fun bf lbl -> - fprintf oc "%a: .long 0x%lx\n" label lbl bf) - literal32_labels - end; - reset_literals () - end - -(* Generate code to load the address of id + ofs in register r *) - - let loadsymbol oc r id ofs = - if Archi.pic_code () then begin - assert (ofs = Integers.Ptrofs.zero); - if C2C.atom_is_thread_local id then begin - (* fprintf oc " addd %a = $r13, @tprel(%s)\n" ireg r (extern_atom id) *) - fprintf oc " addd %a = $r13, @tlsle(%s)\n" ireg r (extern_atom id) - end else begin - fprintf oc " make %a = %s\n" ireg r (extern_atom id) - end - end else - begin - if C2C.atom_is_thread_local id then begin - (* fprintf oc " addd %a = $r13, @tprel(%a)\n" ireg r symbol_offset (id, ofs) *) - fprintf oc " addd %a = $r13, @tlsle(%a)\n" ireg r symbol_offset (id, ofs) - end else begin - fprintf oc " make %a = %a\n" ireg r symbol_offset (id, ofs) - end - end - -(* Emit .file / .loc debugging directives *) - - let print_file_line oc file line = - print_file_line oc comment file line - -(* - let print_location oc loc = - if loc <> Cutil.no_loc then print_file_line oc (fst loc) (snd loc) -*) - -(* Add "w" suffix to 32-bit instructions if we are in 64-bit mode *) - - (*let w oc = - if Archi.ptr64 then output_string oc "w" - *) - - (* Profiling *) - - - let k1c_profiling_stub oc nr_items - profiling_id_table_name - profiling_counter_table_name = - fprintf oc " make $r0 = %d\n" nr_items; - fprintf oc " make $r1 = %s\n" profiling_id_table_name; - fprintf oc " make $r2 = %s\n" profiling_counter_table_name; - fprintf oc " goto %s\n" profiling_write_table_helper; - fprintf oc " ;;\n";; - - (* Offset part of a load or store *) - - let offset oc n = ptrofs oc n - - let addressing oc = function - | AOff ofs -> offset oc ofs - | AReg ro | ARegXS ro -> ireg oc ro - - let xscale oc = function - | ARegXS _ -> fprintf oc ".xs" - | _ -> () - - let lsvariant oc = function - | TRAP -> () - | NOTRAP -> output_string oc ".s" - - let icond_name = let open Asmvliw in function - | ITne | ITneu -> "ne" - | ITeq | ITequ -> "eq" - | ITlt -> "lt" - | ITge -> "ge" - | ITle -> "le" - | ITgt -> "gt" - | ITltu -> "ltu" - | ITgeu -> "geu" - | ITleu -> "leu" - | ITgtu -> "gtu" - - let icond oc c = fprintf oc "%s" (icond_name c) - - let fcond_name = let open Asmvliw in function - | FTone -> "one" - | FTueq -> "ueq" - | FToeq -> "oeq" - | FTune -> "une" - | FTolt -> "olt" - | FTuge -> "uge" - | FToge -> "oge" - | FTult -> "ult" - - let fcond oc c = fprintf oc "%s" (fcond_name c) - - let bcond_name = let open Asmvliw in function - | BTwnez -> "wnez" - | BTweqz -> "weqz" - | BTwltz -> "wltz" - | BTwgez -> "wgez" - | BTwlez -> "wlez" - | BTwgtz -> "wgtz" - | BTdnez -> "dnez" - | BTdeqz -> "deqz" - | BTdltz -> "dltz" - | BTdgez -> "dgez" - | BTdlez -> "dlez" - | BTdgtz -> "dgtz" - - let bcond oc c = fprintf oc "%s" (bcond_name c) - -(* Printing of instructions *) - exception ShouldBeExpanded - - let print_instruction oc = function - (* Pseudo-instructions expanded in Asmexpand *) - | Pallocframe(sz, ofs) -> assert false - | Pfreeframe(sz, ofs) -> assert false - - (* Pseudo-instructions that remain *) - | Plabel lbl -> - fprintf oc "%a:\n" print_label lbl - | Ploadsymbol(rd, id, ofs) -> - loadsymbol oc rd id ofs - | Pbuiltin(ef, args, res) -> - begin match ef with - | EF_annot(kind,txt, targs) -> - begin match (P.to_int kind) with - | 1 -> let annot = annot_text preg_annot "x2" (camlstring_of_coqstring txt) args in - fprintf oc "%s annotation: %S\n" comment annot - (*| 2 -> let lbl = new_label () in - fprintf oc "%a: " label lbl; - add_ais_annot lbl preg_annot "x2" (camlstring_of_coqstring txt) args - *)| _ -> assert false - end - | EF_debug(kind, txt, targs) -> - print_debug_info comment print_file_line preg_annot "sp" oc - (P.to_int kind) (extern_atom txt) args - | EF_inline_asm(txt, sg, clob) -> - fprintf oc "%s begin inline assembly\n\t" comment; - print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res; - fprintf oc "%s end inline assembly\n" comment - | EF_profiling(id, coq_kind) -> - let kind = Z.to_int coq_kind in - assert (kind >= 0); - assert (kind <= 1); - fprintf oc "%s profiling %a %d\n" comment - Profilingaux.pp_id id kind; - fprintf oc " make $r63 = %s\n" profiling_counter_table_name; - fprintf oc " make $r62 = 1\n"; - fprintf oc " ;;\n"; - fprintf oc " afaddd %d[$r63] = $r62\n" - (profiling_offset id kind); - fprintf oc " ;;\n" - | _ -> - assert false - end - | Pnop -> (* FIXME fprintf oc " nop\n" *) () - | Psemi -> fprintf oc ";;\n" - - | Pclzll (rd, rs) -> fprintf oc " clzd %a = %a\n" ireg rd ireg rs - | Pstsud (rd, rs1, rs2) -> fprintf oc " stsud %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - - - (* Control flow instructions *) - | Pget (rd, rs) -> - fprintf oc " get %a = %a\n" ireg rd preg rs - | Pset (rd, rs) -> - fprintf oc " set %a = %a\n" preg rd ireg rs - | Pret -> - fprintf oc " ret \n" - | Pcall(s) -> - fprintf oc " call %a\n" symbol s - | Picall(rs) -> - fprintf oc " icall %a\n" ireg rs - | Pgoto(s) -> - fprintf oc " goto %a\n" symbol s - | Pigoto(rs) -> - fprintf oc " igoto %a\n" ireg rs - | Pj_l(s) -> - fprintf oc " goto %a\n" print_label s - | Pcb (bt, r, lbl) | Pcbu (bt, r, lbl) -> - fprintf oc " cb.%a %a? %a\n" bcond bt ireg r print_label lbl - - (* For builtins *) - | Ploopdo (r, lbl) -> - fprintf oc " loopdo %a, %a\n" ireg r print_label lbl - | Pgetn(n, dst) -> - fprintf oc " get %a = $s%ld\n" ireg dst (camlint_of_coqint n) - | Psetn(n, dst) -> - fprintf oc " set $s%ld = %a\n" (camlint_of_coqint n) ireg dst - | Pwfxl(n, dst) -> - fprintf oc " wfxl $s%ld = %a\n" (camlint_of_coqint n) ireg dst - | Pwfxm(n, dst) -> - fprintf oc " wfxm $s%ld = %a\n" (camlint_of_coqint n) ireg dst - | Pldu(dst, addr) -> - fprintf oc " ld.u %a = 0[%a]\n" ireg dst ireg addr - | Plbzu(dst, addr) -> - fprintf oc " lbz.u %a = 0[%a]\n" ireg dst ireg addr - | Plhzu(dst, addr) -> - fprintf oc " lhz.u %a = 0[%a]\n" ireg dst ireg addr - | Plwzu(dst, addr) -> - fprintf oc " lwz.u %a = 0[%a]\n" ireg dst ireg addr - | Pawait -> - fprintf oc " await\n" - | Psleep -> - fprintf oc " sleep\n" - | Pstop -> - fprintf oc " stop\n" - | Pbarrier -> - fprintf oc " barrier\n" - | Pfence -> - fprintf oc " fence\n" - | Pdinval -> - fprintf oc " dinval\n" - | Pdinvall addr -> - fprintf oc " dinvall 0[%a]\n" ireg addr - | Pdtouchl addr -> - fprintf oc " dtouchl 0[%a]\n" ireg addr - | Piinval -> - fprintf oc " iinval\n" - | Piinvals addr -> - fprintf oc " iinvals 0[%a]\n" ireg addr - | Pitouchl addr -> - fprintf oc " itouchl 0[%a]\n" ireg addr - | Pdzerol addr -> - fprintf oc " dzerol 0[%a]\n" ireg addr -(* | Pafaddd(addr, incr_res) -> - fprintfoc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res - | Pafaddw(addr, incr_res) -> - fprintfoc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *) - | Palclrd(res, addr) -> - fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr - | Palclrw(res, addr) -> - fprintf oc " alclrw %a = 0[%a]\n" ireg res ireg addr - | Pjumptable (idx_reg, tbl) -> - let lbl = new_label() in - (* jumptables := (lbl, tbl) :: !jumptables; *) - let base_reg = if idx_reg=Asmvliw.GPR63 then Asmvliw.GPR62 else Asmvliw.GPR63 in - fprintf oc "%s jumptable [ " comment; - List.iter (fun l -> fprintf oc "%a " print_label l) tbl; - fprintf oc "]\n"; - fprintf oc " make %a = %a\n ;;\n" ireg base_reg label lbl; - fprintf oc " ld.xs %a = %a[%a]\n ;;\n" ireg base_reg ireg idx_reg ireg base_reg; - fprintf oc " igoto %a\n ;;\n" ireg base_reg; - section oc Section_jumptable; - print_tbl oc (lbl, tbl); - section oc Section_text - - (* Load/Store instructions *) - | Plb(trap, rd, ra, adr) -> - fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Plbu(trap, rd, ra, adr) -> - fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Plh(trap, rd, ra, adr) -> - fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Plhu(trap, rd, ra, adr) -> - fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) -> - fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra - | Plq(rd, ra, adr) -> - fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra - | Plo(rd, ra, adr) -> - fprintf oc " lo%a %a = %a[%a]\n" xscale adr gpreg_o rd addressing adr ireg ra - - | Psb(rd, ra, adr) -> - fprintf oc " sb%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd - | Psh(rd, ra, adr) -> - fprintf oc " sh%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd - | Psw(rd, ra, adr) | Psw_a(rd, ra, adr) | Pfss(rd, ra, adr) -> - fprintf oc " sw%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd - | Psd(rd, ra, adr) | Psd_a(rd, ra, adr) | Pfsd(rd, ra, adr) -> assert Archi.ptr64; - fprintf oc " sd%a %a[%a] = %a\n" xscale adr addressing adr ireg ra ireg rd - | Psq(rd, ra, adr) -> - fprintf oc " sq%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_q rd - | Pso(rd, ra, adr) -> - fprintf oc " so%a %a[%a] = %a\n" xscale adr addressing adr ireg ra gpreg_o rd - - (* Arith R instructions *) - - (* Arith RR instructions *) - | Pmv(rd, rs) -> - fprintf oc " addd %a = %a, 0\n" ireg rd ireg rs - | Pcvtl2w(rd, rs) -> assert false - | Pnegl(rd, rs) -> assert Archi.ptr64; - fprintf oc " negd %a = %a\n" ireg rd ireg rs - | Pnegw(rd, rs) -> - fprintf oc " negw %a = %a\n" ireg rd ireg rs - | Psxwd(rd, rs) -> - fprintf oc " sxwd %a = %a\n" ireg rd ireg rs - | Pzxwd(rd, rs) -> - fprintf oc " zxwd %a = %a\n" ireg rd ireg rs - | Pextfz(rd, rs, stop, start) | Pextfzl(rd, rs, stop, start) -> - fprintf oc " extfz %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) - | Pextfs(rd, rs, stop, start) | Pextfsl(rd, rs, stop, start) -> - fprintf oc " extfs %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) - | Pinsf(rd, rs, stop, start) | Pinsfl(rd, rs, stop, start) -> - fprintf oc " insf %a = %a, %ld, %ld\n" ireg rd ireg rs (camlint_of_coqint stop) (camlint_of_coqint start) - | Pfabsd(rd, rs) -> - fprintf oc " fabsd %a = %a\n" ireg rd ireg rs - | Pfabsw(rd, rs) -> - fprintf oc " fabsw %a = %a\n" ireg rd ireg rs - | Pfnegd(rd, rs) -> - fprintf oc " fnegd %a = %a\n" ireg rd ireg rs - | Pfnegw(rd, rs) -> - fprintf oc " fnegw %a = %a\n" ireg rd ireg rs - | Pfnarrowdw(rd, rs) -> - fprintf oc " fnarrowdw %a = %a\n" ireg rd ireg rs - | Pfwidenlwd(rd, rs) -> - fprintf oc " fwidenlwd %a = %a\n" ireg rd ireg rs - | Pfloatuwrnsz(rd, rs) -> - fprintf oc " floatuw.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatwrnsz(rd, rs) -> - fprintf oc " floatw.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatudrnsz(rd, rs) -> - fprintf oc " floatud.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfloatdrnsz(rd, rs) -> - fprintf oc " floatd.rn.s %a = %a, 0\n" ireg rd ireg rs - | Pfixedwrzz(rd, rs) -> - fprintf oc " fixedw.rz %a = %a, 0\n" ireg rd ireg rs - | Pfixeduwrzz(rd, rs) -> - fprintf oc " fixeduw.rz %a = %a, 0\n" ireg rd ireg rs - | Pfixeddrzz(rd, rs) | Pfixeddrzz_i32(rd, rs) -> - fprintf oc " fixedd.rz %a = %a, 0\n" ireg rd ireg rs - | Pfixedudrzz(rd, rs) | Pfixedudrzz_i32(rd, rs) -> - fprintf oc " fixedud.rz %a = %a, 0\n" ireg rd ireg rs - - (* Arith RI32 instructions *) - | Pmake (rd, imm) -> - fprintf oc " make %a, %a\n" ireg rd coqint imm - - (* Arith RI64 instructions *) - | Pmakel (rd, imm) -> - fprintf oc " make %a, %a\n" ireg rd coqint64 imm - - (* Arith RF32 instructions *) - | Pmakefs (rd, f) -> - let d = Floats.Float32.to_bits f in - fprintf oc " make %a, %a %s %.18g\n" - ireg rd coqint d comment (camlfloat_of_coqfloat32 f) - - (* Arith RF64 instructions *) - | Pmakef (rd, f) -> - let d = Floats.Float.to_bits f in - fprintf oc " make %a, %a %s %.18g\n" - ireg rd coqint64 d comment (camlfloat_of_coqfloat f) - - (* Arith RRR instructions *) - | Pcompw (it, rd, rs1, rs2) -> - fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 - | Pcompl (it, rd, rs1, rs2) -> - fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs1 ireg rs2 - - | Pfcompw (ft, rd, rs1, rs2) -> - fprintf oc " fcompw.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 - | Pfcompl (ft, rd, rs1, rs2) -> - fprintf oc " fcompd.%a %a = %a, %a\n" fcond ft ireg rd ireg rs1 ireg rs2 - - | Paddw (rd, rs1, rs2) -> - fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxw (s14, rd, rs1, rs2) -> - fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs1 ireg rs2 - | Psubw (rd, rs1, rs2) -> - fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Prevsubxw (s14, rd, rs1, rs2) -> - fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs1 ireg rs2 - | Pmulw (rd, rs1, rs2) -> - fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pandw (rd, rs1, rs2) -> - fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnandw (rd, rs1, rs2) -> - fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porw (rd, rs1, rs2) -> - fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnorw (rd, rs1, rs2) -> - fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorw (rd, rs1, rs2) -> - fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnxorw (rd, rs1, rs2) -> - fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pandnw (rd, rs1, rs2) -> - fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pornw (rd, rs1, rs2) -> - fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psraw (rd, rs1, rs2) -> - fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psrxw (rd, rs1, rs2) -> - fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psrlw (rd, rs1, rs2) -> - fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psllw (rd, rs1, rs2) -> - fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmaddw (rd, rs1, rs2) -> - fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmsubw (rd, rs1, rs2) -> - fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmaddfw (rd, rs1, rs2) -> - fprintf oc " ffmaw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmsubfw (rd, rs1, rs2) -> - fprintf oc " ffmsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Paddl (rd, rs1, rs2) -> - fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Paddxl (s14, rd, rs1, rs2) -> - fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs1 ireg rs2 - | Psubl (rd, rs1, rs2) -> - fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Prevsubxl (s14, rd, rs1, rs2) -> - fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs1 ireg rs2 - | Pandl (rd, rs1, rs2) -> - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnandl (rd, rs1, rs2) -> - fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Porl (rd, rs1, rs2) -> - fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnorl (rd, rs1, rs2) -> - fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pxorl (rd, rs1, rs2) -> - fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pnxorl (rd, rs1, rs2) -> - fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pandnl (rd, rs1, rs2) -> - fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pornl (rd, rs1, rs2) -> - fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmull (rd, rs1, rs2) -> - fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pslll (rd, rs1, rs2) -> - fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psrll (rd, rs1, rs2) -> - fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psrxl (rd, rs1, rs2) -> - fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Psral (rd, rs1, rs2) -> - fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmaddl (rd, rs1, rs2) -> - fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pmsubl (rd, rs1, rs2) -> - fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmaddfl (rd, rs1, rs2) -> - fprintf oc " ffmad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmsubfl (rd, rs1, rs2) -> - fprintf oc " ffmsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - - | Pfaddd (rd, rs1, rs2) -> - fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfaddw (rd, rs1, rs2) -> - fprintf oc " faddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfsbfd (rd, rs1, rs2) -> - fprintf oc " fsbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Pfsbfw (rd, rs1, rs2) -> - fprintf oc " fsbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1 - | Pfmuld (rd, rs1, rs2) -> - fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmulw (rd, rs1, rs2) -> - fprintf oc " fmulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmind (rd, rs1, rs2) -> - fprintf oc " fmind %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfminw (rd, rs1, rs2) -> - fprintf oc " fminw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmaxd (rd, rs1, rs2) -> - fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfmaxw (rd, rs1, rs2) -> - fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2 - | Pfinvw (rd, rs1) -> - fprintf oc " finvw %a = %a\n" ireg rd ireg rs1 - - (* Arith RRI32 instructions *) - | Pcompiw (it, rd, rs, imm) -> - fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm - | Paddiw (rd, rs, imm) -> - fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Paddxiw (s14, rd, rs, imm) -> - fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs coqint imm - | Prevsubiw (rd, rs, imm) -> - fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Prevsubxiw (s14, rd, rs, imm) -> - fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs coqint imm - | Pmuliw (rd, rs, imm) -> - fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pandiw (rd, rs, imm) -> - fprintf oc " andw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pnandiw (rd, rs, imm) -> - fprintf oc " nandw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Poriw (rd, rs, imm) -> - fprintf oc " orw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pnoriw (rd, rs, imm) -> - fprintf oc " norw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pxoriw (rd, rs, imm) -> - fprintf oc " xorw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pnxoriw (rd, rs, imm) -> - fprintf oc " nxorw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pandniw (rd, rs, imm) -> - fprintf oc " andnw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Porniw (rd, rs, imm) -> - fprintf oc " ornw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psraiw (rd, rs, imm) -> - fprintf oc " sraw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psrxiw (rd, rs, imm) -> - fprintf oc " srsw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Psrliw (rd, rs, imm) -> - fprintf oc " srlw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pslliw (rd, rs, imm) -> - fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Proriw (rd, rs, imm) -> - fprintf oc " rorw %a = %a, %a\n" ireg rd ireg rs coqint imm - | Pmaddiw (rd, rs, imm) -> - fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs coqint imm - - | Psllil (rd, rs, imm) -> - fprintf oc " slld %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psrlil (rd, rs, imm) -> - fprintf oc " srld %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psrail (rd, rs, imm) -> - fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Psrxil (rd, rs, imm) -> - fprintf oc " srsd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - - (* Arith RRI64 instructions *) - | Pcompil (it, rd, rs, imm) -> - fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm - | Paddil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Paddxil (s14, rd, rs, imm) -> - fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs coqint imm - | Prevsubil (rd, rs, imm) -> - fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Prevsubxil (s14, rd, rs, imm) -> - fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14) - ireg rd ireg rs coqint64 imm - | Pmulil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pnandil (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Poril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pnoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pnxoril (rd, rs, imm) -> assert Archi.ptr64; - fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pandnil (rd, rs, imm) -> - fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pornil (rd, rs, imm) -> - fprintf oc " ornd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - | Pmaddil (rd, rs, imm) -> - fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs coqint64 imm - - | Pcmove (bt, rd, rcond, rs) | Pcmoveu (bt, rd, rcond, rs) -> - fprintf oc " cmoved.%a %a? %a = %a\n" - bcond bt ireg rcond ireg rd ireg rs - | Pcmoveiw (bt, rd, rcond, imm) | Pcmoveuiw (bt, rd, rcond, imm) -> - fprintf oc " cmoved.%a %a? %a = %a\n" - bcond bt ireg rcond ireg rd coqint imm - | Pcmoveil (bt, rd, rcond, imm) | Pcmoveuil (bt, rd, rcond, imm) -> - fprintf oc " cmoved.%a %a? %a = %a\n" - bcond bt ireg rcond ireg rd coqint64 imm - - let get_section_names name = - let (text, lit) = - match C2C.atom_sections name with - | t :: l :: _ -> (t, l) - | _ -> (Section_text, Section_literal) in - text,lit,Section_jumptable - - let print_align oc alignment = - fprintf oc " .balign %d\n" alignment - - let print_jumptable oc jmptbl = () - (* if !jumptables <> [] then - begin - section oc jmptbl; - List.iter (print_tbl oc) !jumptables; - jumptables := [] - end *) - - let print_fun_info = elf_print_fun_info - - let print_optional_fun_info _ = () - - let print_var_info = elf_print_var_info - - let print_comm_symb oc sz name align = - if C2C.atom_is_static name then - fprintf oc " .local %a\n" symbol name; - fprintf oc " .comm %a, %s, %d\n" - symbol name - (Z.to_string sz) - align - - let print_instructions oc fn = - current_function_sig := fn.fn_sig; - List.iter (print_instruction oc) fn.fn_code - -(* Data *) - - let address = if Archi.ptr64 then ".quad" else ".long" - - let print_prologue oc = - (* fprintf oc " .option %s\n" (if Archi.pic_code() then "pic" else "nopic"); *) - if !Clflags.option_g then begin - section oc Section_text; - end - - let print_epilogue oc = - print_profiling_epilogue elf_text_print_fun_info Dtors k1c_profiling_stub oc; - if !Clflags.option_g then begin - Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f)); - section oc Section_text; - end - - let default_falignment = 2 - - let cfi_startproc oc = () - let cfi_endproc oc = () - - end - -let sel_target () = - (module Target:TARGET) diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v deleted file mode 100644 index e634fdc0..00000000 --- a/mppa_k1c/ValueAOp.v +++ /dev/null @@ -1,884 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib Compopts. -Require Import AST Integers Floats Values Memory Globalenvs. -Require Import Op ExtValues ExtFloats RTL ValueDomain. - -Definition intoffloat_total (x: aval) := - match x with - | F f => - match Float.to_int f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intuoffloat_total (x: aval) := - match x with - | F f => - match Float.to_intu f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_int f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition intuofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_intu f with - | Some i => I i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longoffloat_total (x: aval) := - match x with - | F f => - match Float.to_long f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longuoffloat_total (x: aval) := - match x with - | F f => - match Float.to_longu f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_long f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition longuofsingle_total (x: aval) := - match x with - | FS f => - match Float32.to_longu f with - | Some i => L i - | None => ntop - end - | _ => ntop1 x - end. - -Definition minf := binop_float ExtFloat.min. -Definition maxf := binop_float ExtFloat.max. -Definition minfs := binop_single ExtFloat32.min. -Definition maxfs := binop_single ExtFloat32.max. - -Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))). - -Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) := - match x, y, z with - | F a, F b, F c => F (sem a b c) - | _, _, _ => ntop3 x y z - end. - -Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) := - match x, y, z with - | FS a, FS b, FS c => FS (sem a b c) - | _, _, _ => ntop3 x y z - end. - -Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x). -Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x). -Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x). -Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x). - -Definition invfs (y : aval) := - match y with - | FS f => FS (ExtFloat32.inv f) - | _ => ntop1 y - end. - -(** Value analysis for RISC V operators *) - -Definition eval_static_condition (cond: condition) (vl: list aval): abool := - match cond, vl with - | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2 - | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2 - | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n) - | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n) - | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2 - | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2 - | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n) - | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n) - | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2 - | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2) - | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2 - | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2) - | _, _ => Bnone - end. - -Definition eval_static_addressing (addr: addressing) (vl: list aval): aval := - match addr, vl with - | Aindexed n, v1::nil => offset_ptr v1 n - | Aindexed2, v1::v2::nil => addl v1 v2 - | Aindexed2XS scale, v1::v2::nil => addl v1 (shll v2 (I (Int.repr scale))) - | Aglobal s ofs, nil => Ptr (Gl s ofs) - | Ainstack ofs, nil => Ptr (Stk ofs) - | _, _ => Vbot - end. - -Definition eval_static_condition0 (cond : condition0) (v : aval) : abool := - match cond with - | Ccomp0 c => cmp_bool c v (I Int.zero) - | Ccompu0 c => cmpu_bool c v (I Int.zero) - | Ccompl0 c => cmpl_bool c v (L Int64.zero) - | Ccomplu0 c => cmplu_bool c v (L Int64.zero) - end. - - -Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) := - if is_bitfield stop start - then - let stop' := Z.add stop Z.one in - match v with - | I w => - I (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) - | _ => Vtop - end - else Vtop. - -Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) := - if is_bitfield stop start - then - let stop' := Z.add stop Z.one in - match v with - | I w => - I (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start)))) - | _ => Vtop - end - else Vtop. - -Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) := - if is_bitfieldl stop start - then - let stop' := Z.add stop Z.one in - match v with - | L w => - L (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) - | _ => Vtop - end - else Vtop. - -Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) := - if is_bitfieldl stop start - then - let stop' := Z.add stop Z.one in - match v with - | L w => - L (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start)))) - | _ => Vtop - end - else Vtop. - -Definition eval_static_insf stop start prev fld := - let mask := Int.repr (zbitfield_mask stop start) in - if is_bitfield stop start - then - match prev, fld with - | (I prevI), (I fldI) => - if Int.ltu (Int.repr start) Int.iwordsize - then I (Int.or (Int.and prevI (Int.not mask)) - (Int.and (Int.shl fldI (Int.repr start)) mask)) - else Vtop - | _, _ => Vtop - end - else Vtop. - -Definition eval_static_insfl stop start prev fld := - let mask := Int64.repr (zbitfield_mask stop start) in - if is_bitfieldl stop start - then - match prev, fld with - | (L prevL), (L fldL) => - if Int.ltu (Int.repr start) Int64.iwordsize' - then L (Int64.or (Int64.and prevL (Int64.not mask)) - (Int64.and (Int64.shl' fldL (Int.repr start)) mask)) - else Vtop - | _,_ => Vtop - end - else Vtop. - -Definition eval_static_operation (op: operation) (vl: list aval): aval := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => I n - | Olongconst n, nil => L n - | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop - | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop - | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs) - | Oaddrstack ofs, nil => Ptr (Stk ofs) - | Ocast8signed, v1 :: nil => sign_ext 8 v1 - | Ocast16signed, v1 :: nil => sign_ext 16 v1 - | Oadd, v1::v2::nil => add v1 v2 - | Oaddimm n, v1::nil => add v1 (I n) - | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift))) - | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift))) - | Oneg, v1::nil => neg v1 - | Osub, v1::v2::nil => sub v1 v2 - | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift))) - | Orevsubimm n, v1::nil => sub (I n) v1 - | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift))) - | Omul, v1::v2::nil => mul v1 v2 - | Omulimm n, v1::nil => mul v1 (I n) - | Omulhs, v1::v2::nil => mulhs v1 v2 - | Omulhu, v1::v2::nil => mulhu v1 v2 - | Odiv, v1::v2::nil => divs v1 v2 - | Odivu, v1::v2::nil => divu v1 v2 - | Omod, v1::v2::nil => mods v1 v2 - | Omodu, v1::v2::nil => modu v1 v2 - | Oand, v1::v2::nil => and v1 v2 - | Oandimm n, v1::nil => and v1 (I n) - | Onand, v1::v2::nil => notint (and v1 v2) - | Onandimm n, v1::nil => notint (and v1 (I n)) - | Oor, v1::v2::nil => or v1 v2 - | Oorimm n, v1::nil => or v1 (I n) - | Onor, v1::v2::nil => notint (or v1 v2) - | Onorimm n, v1::nil => notint (or v1 (I n)) - | Oxor, v1::v2::nil => xor v1 v2 - | Oxorimm n, v1::nil => xor v1 (I n) - | Onxor, v1::v2::nil => notint (xor v1 v2) - | Onxorimm n, v1::nil => notint (xor v1 (I n)) - | Onot, v1::nil => notint v1 - | Oandn, v1::v2::nil => and (notint v1) v2 - | Oandnimm n, v1::nil => and (notint v1) (I n) - | Oorn, v1::v2::nil => or (notint v1) v2 - | Oornimm n, v1::nil => or (notint v1) (I n) - | Oshl, v1::v2::nil => shl v1 v2 - | Oshlimm n, v1::nil => shl v1 (I n) - | Oshr, v1::v2::nil => shr v1 v2 - | Oshrimm n, v1::nil => shr v1 (I n) - | Ororimm n, v1::nil => ror v1 (I n) - | Oshru, v1::v2::nil => shru v1 v2 - | Oshruimm n, v1::nil => shru v1 (I n) - | Oshrximm n, v1::nil => shrx v1 (I n) - | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3) - | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n)) - | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3) - | Omakelong, v1::v2::nil => longofwords v1 v2 - | Olowlong, v1::nil => loword v1 - | Ohighlong, v1::nil => hiword v1 - | Ocast32signed, v1::nil => longofint v1 - | Ocast32unsigned, v1::nil => longofintu v1 - | Oaddl, v1::v2::nil => addl v1 v2 - | Oaddlimm n, v1::nil => addl v1 (L n) - | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift))) - | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift))) - | Onegl, v1::nil => negl v1 - | Osubl, v1::v2::nil => subl v1 v2 - | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift))) - | Orevsublimm n, v1::nil => subl (L n) v1 - | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift))) - | Omull, v1::v2::nil => mull v1 v2 - | Omullimm n, v1::nil => mull v1 (L n) - | Omullhs, v1::v2::nil => mullhs v1 v2 - | Omullhu, v1::v2::nil => mullhu v1 v2 - | Odivl, v1::v2::nil => divls v1 v2 - | Odivlu, v1::v2::nil => divlu v1 v2 - | Omodl, v1::v2::nil => modls v1 v2 - | Omodlu, v1::v2::nil => modlu v1 v2 - | Oandl, v1::v2::nil => andl v1 v2 - | Oandlimm n, v1::nil => andl v1 (L n) - | Onandl, v1::v2::nil => notl (andl v1 v2) - | Onandlimm n, v1::nil => notl (andl v1 (L n)) - | Oorl, v1::v2::nil => orl v1 v2 - | Oorlimm n, v1::nil => orl v1 (L n) - | Onorl, v1::v2::nil => notl (orl v1 v2) - | Onorlimm n, v1::nil => notl (orl v1 (L n)) - | Oxorl, v1::v2::nil => xorl v1 v2 - | Oxorlimm n, v1::nil => xorl v1 (L n) - | Onxorl, v1::v2::nil => notl (xorl v1 v2) - | Onxorlimm n, v1::nil => notl (xorl v1 (L n)) - | Onotl, v1::nil => notl v1 - | Oandnl, v1::v2::nil => andl (notl v1) v2 - | Oandnlimm n, v1::nil => andl (notl v1) (L n) - | Oornl, v1::v2::nil => orl (notl v1) v2 - | Oornlimm n, v1::nil => orl (notl v1) (L n) - | Oshll, v1::v2::nil => shll v1 v2 - | Oshllimm n, v1::nil => shll v1 (I n) - | Oshrl, v1::v2::nil => shrl v1 v2 - | Oshrlimm n, v1::nil => shrl v1 (I n) - | Oshrlu, v1::v2::nil => shrlu v1 v2 - | Oshrluimm n, v1::nil => shrlu v1 (I n) - | Oshrxlimm n, v1::nil => shrxl v1 (I n) - | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3) - | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n)) - | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3) - | Onegf, v1::nil => negf v1 - | Oabsf, v1::nil => absf v1 - | Oaddf, v1::v2::nil => addf v1 v2 - | Osubf, v1::v2::nil => subf v1 v2 - | Omulf, v1::v2::nil => mulf v1 v2 - | Odivf, v1::v2::nil => divf v1 v2 - | Ominf, v1::v2::nil => minf v1 v2 - | Omaxf, v1::v2::nil => maxf v1 v2 - | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3 - | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3 - | Onegfs, v1::nil => negfs v1 - | Oabsfs, v1::nil => absfs v1 - | Oaddfs, v1::v2::nil => addfs v1 v2 - | Osubfs, v1::v2::nil => subfs v1 v2 - | Omulfs, v1::v2::nil => mulfs v1 v2 - | Odivfs, v1::v2::nil => divfs v1 v2 - | Ominfs, v1::v2::nil => minfs v1 v2 - | Omaxfs, v1::v2::nil => maxfs v1 v2 - | Oinvfs, v1::nil => invfs v1 - | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3 - | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3 - | Osingleoffloat, v1::nil => singleoffloat v1 - | Ofloatofsingle, v1::nil => floatofsingle v1 - | Ointoffloat, v1::nil => intoffloat_total v1 - | Ointuoffloat, v1::nil => intuoffloat_total v1 - | Ointofsingle, v1::nil => intofsingle_total v1 - | Ointuofsingle, v1::nil => intuofsingle_total v1 - | Osingleofint, v1::nil => singleofint v1 - | Osingleofintu, v1::nil => singleofintu v1 - | Olongoffloat, v1::nil => longoffloat_total v1 - | Olonguoffloat, v1::nil => longuoffloat_total v1 - | Ofloatoflong, v1::nil => floatoflong v1 - | Ofloatoflongu, v1::nil => floatoflongu v1 - | Olongofsingle, v1::nil => longofsingle_total v1 - | Olonguofsingle, v1::nil => longuofsingle_total v1 - | Osingleoflong, v1::nil => singleoflong v1 - | Osingleoflongu, v1::nil => singleoflongu v1 - | Ocmp c, _ => of_optbool (eval_static_condition c vl) - | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0 - | (Oextfs stop start), v0::nil => eval_static_extfs stop start v0 - | (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0 - | (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0 - | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1 - | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1 - | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2 - | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm) - | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm) - | _, _ => Vbot - end. - -Section SOUNDNESS. - -Variable bc: block_classification. -Variable ge: genv. -Hypothesis GENV: genv_match bc ge. -Variable sp: block. -Hypothesis STACK: bc sp = BCstack. - -Lemma intoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intoffloat v)) (intoffloat_total x). -Proof. - unfold Val.intoffloat, intoffloat_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intoffloat_total_sound : va. - -Lemma intuoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intuoffloat v)) (intuoffloat_total x). -Proof. - unfold Val.intoffloat, intoffloat_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intuoffloat_total_sound : va. - -Lemma intofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intofsingle v)) (intofsingle_total x). -Proof. - unfold Val.intofsingle, intofsingle_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float32.to_int f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intofsingle_total_sound : va. - -Lemma intuofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.intuofsingle v)) (intuofsingle_total x). -Proof. - unfold Val.intofsingle, intofsingle_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float32.to_intu f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve intuofsingle_total_sound : va. - -Lemma singleofint_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleofint v)) (singleofint x). -Proof. - unfold Val.singleofint, singleofint; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleofint_total_sound : va. - -Lemma singleofintu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleofintu v)) (singleofintu x). -Proof. - unfold Val.singleofintu, singleofintu; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleofintu_total_sound : va. - -Lemma longoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longoffloat v)) (longoffloat_total x). -Proof. - unfold Val.longoffloat, longoffloat_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longoffloat_total_sound : va. - -Lemma longuoffloat_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longuoffloat v)) (longuoffloat_total x). -Proof. - unfold Val.longoffloat, longoffloat_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longuoffloat_total_sound : va. - -Lemma longofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longofsingle v)) (longofsingle_total x). -Proof. - unfold Val.longofsingle, longofsingle_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float32.to_long f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longofsingle_total_sound : va. - -Lemma longuofsingle_total_sound: - forall v x - (MATCH : vmatch bc v x), - vmatch bc (Val.maketotal (Val.longuofsingle v)) (longuofsingle_total x). -Proof. - unfold Val.longofsingle, longofsingle_total. intros. - inv MATCH; simpl in *; try constructor. - all: destruct (Float32.to_longu f) as [i|] eqn:E; simpl; [auto with va | constructor]. - unfold ntop1, provenance. - destruct (va_strict tt); constructor. -Qed. - -Hint Resolve longuofsingle_total_sound : va. - -Lemma singleoflong_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleoflong v)) (singleoflong x). -Proof. - unfold Val.singleoflong, singleoflong; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleoflong_total_sound : va. - -Lemma singleoflongu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.singleoflongu v)) (singleoflongu x). -Proof. - unfold Val.singleoflongu, singleoflongu; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve singleoflongu_total_sound : va. - -Lemma floatoflong_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.floatoflong v)) (floatoflong x). -Proof. - unfold Val.floatoflong, floatoflong; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve floatoflong_total_sound : va. - -Lemma floatoflongu_total_sound: - forall v x, vmatch bc v x -> - vmatch bc (Val.maketotal (Val.floatoflongu v)) (floatoflongu x). -Proof. - unfold Val.floatoflongu, floatoflongu; intros. - inv H; simpl. - all: auto with va. - all: unfold ntop1, provenance. - all: try constructor. -Qed. - -Hint Resolve floatoflongu_total_sound : va. - -Lemma minf_sound: - forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y). -Proof. - apply (binop_float_sound bc ExtFloat.min); assumption. -Qed. - -Lemma maxf_sound: - forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y). -Proof. - apply (binop_float_sound bc ExtFloat.max); assumption. -Qed. - -Lemma minfs_sound: - forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y). -Proof. - apply (binop_single_sound bc ExtFloat32.min); assumption. -Qed. - -Lemma maxfs_sound: - forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y). -Proof. - apply (binop_single_sound bc ExtFloat32.max); assumption. -Qed. - -Lemma invfs_sound: - forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x). -Proof. - intros v x; - intro MATCH; - inversion MATCH; - simpl; - constructor. -Qed. - -Lemma triple_op_float_sound: - forall f a x b y c z, - vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.triple_op_float f a b c) - (triple_op_float f x y z). -Proof. - intros until z. - intros Hax Hby Hcz. - inv Hax; simpl; try constructor; - inv Hby; simpl; try constructor; - inv Hcz; simpl; try constructor. -Qed. - -Lemma triple_op_single_sound: - forall f a x b y c z, - vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.triple_op_single f a b c) - (triple_op_single f x y z). -Proof. - intros until z. - intros Hax Hby Hcz. - inv Hax; simpl; try constructor; - inv Hby; simpl; try constructor; - inv Hcz; simpl; try constructor. -Qed. - -Lemma fmaddf_sound : - forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z). -Proof. - intros. unfold ExtValues.fmaddf, fmaddf. - apply triple_op_float_sound; assumption. -Qed. - -Lemma fmaddfs_sound : - forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z). -Proof. - intros. unfold ExtValues.fmaddfs, fmaddfs. - apply triple_op_single_sound; assumption. -Qed. - -Lemma fmsubf_sound : - forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z). -Proof. - intros. unfold ExtValues.fmsubf, fmsubf. - apply triple_op_float_sound; assumption. -Qed. - -Lemma fmsubfs_sound : - forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z -> - vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z). -Proof. - intros. unfold ExtValues.fmsubfs, fmsubfs. - apply triple_op_single_sound; assumption. -Qed. -Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va. - -Theorem eval_static_condition_sound: - forall cond vargs m aargs, - list_forall2 (vmatch bc) vargs aargs -> - cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs). -Proof. - intros until aargs; intros VM. inv VM. - destruct cond; auto with va. - inv H0. - destruct cond; simpl; eauto with va. - inv H2. - destruct cond; simpl; eauto with va. - destruct cond; auto with va. -Qed. - -Theorem eval_static_condition0_sound: - forall cond varg m aarg, - vmatch bc varg aarg -> - cmatch (eval_condition0 cond varg m) (eval_static_condition0 cond aarg). -Proof. - intros until aarg; intro VM. - destruct cond; simpl; eauto with va. -Qed. - -Lemma symbol_address_sound: - forall id ofs, - vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)). -Proof. - intros; apply symbol_address_sound; apply GENV. -Qed. - -Lemma symbol_address_sound_2: - forall id ofs, - vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)). -Proof. - intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F. - constructor. constructor. apply GENV; auto. - constructor. -Qed. - -Hint Resolve symbol_address_sound symbol_address_sound_2: va. - -Ltac InvHyps := - match goal with - | [H: None = Some _ |- _ ] => discriminate - | [H: Some _ = Some _ |- _] => inv H - | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ , - H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps - | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps - | _ => idtac - end. - -Theorem eval_static_addressing_sound: - forall addr vargs vres aargs, - eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_addressing addr aargs). -Proof. - unfold eval_addressing, eval_static_addressing; intros; - destruct addr; InvHyps; eauto with va. - rewrite Ptrofs.add_zero_l; eauto with va. -Qed. - -Theorem eval_static_addressing_sound_none: - forall addr vargs aargs, - eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None -> - list_forall2 (vmatch bc) vargs aargs -> - (eval_static_addressing addr aargs) = Vbot. -Proof. - unfold eval_addressing, eval_static_addressing. - intros until aargs. intros Heval_none Hlist. - inv Hlist. - destruct addr; trivial; discriminate. - inv H0. - destruct addr; trivial; discriminate. - inv H2. - destruct addr; trivial; discriminate. - inv H3; - destruct addr; trivial; discriminate. -Qed. - -Lemma vmatch_vint_ntop1: - forall x y, vmatch bc (Vint x) (ntop1 y). -Proof. - intro. unfold ntop1, provenance. - destruct y; - destruct (va_strict tt); - constructor. -Qed. - -Lemma vmatch_vlong_ntop1: - forall x y, vmatch bc (Vlong x) (ntop1 y). -Proof. - intro. unfold ntop1, provenance. - destruct y; - destruct (va_strict tt); - constructor. -Qed. - -Hint Resolve vmatch_vint_ntop1 vmatch_vlong_ntop1: va. - -Theorem eval_static_operation_sound: - forall op vargs m vres aargs, - eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres -> - list_forall2 (vmatch bc) vargs aargs -> - vmatch bc vres (eval_static_operation op aargs). -Proof. - unfold eval_operation, eval_static_operation, addx, revsubx, addxl, revsubxl; intros. - destruct op; InvHyps; eauto with va. - - destruct (propagate_float_constants tt); constructor. - - destruct (propagate_float_constants tt); constructor. - - rewrite Ptrofs.add_zero_l; eauto with va. - - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with - | Vint n2 => Vint (Int.add n n2) - | Vptr b2 ofs2 => - if Archi.ptr64 - then Vundef - else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n)) - | _ => Vundef - end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). - + eauto with va. - + destruct a1; destruct shift; reflexivity. - - (*revsubimm*) inv H1; constructor. - - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with - | Vint n2 => Vint (Int.sub n n2) - | _ => Vundef - end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))). - + eauto with va. - + destruct n; destruct shift; reflexivity. - - (* shrx *) - inv H1; simpl; try constructor. - all: destruct Int.ltu; [simpl | constructor; fail]. - all: auto with va. - - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with - | Vlong n2 => Vlong (Int64.add n n2) - | Vptr b2 ofs2 => - if Archi.ptr64 - then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n)) - else Vundef - | _ => Vundef - end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). - + eauto with va. - + destruct a1; destruct shift; reflexivity. - - inv H1; constructor. - - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with - | Vlong n2 => Vlong (Int64.sub n n2) - | _ => Vundef - end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))). - + eauto with va. - + destruct a1; destruct shift; reflexivity. - - (* shrxl *) - inv H1; simpl; try constructor. - all: destruct Int.ltu; [simpl | constructor; fail]. - all: auto with va. - - apply of_optbool_sound. eapply eval_static_condition_sound; eauto. - - (* extfz *) - - unfold extfz, eval_static_extfz. - destruct (is_bitfield _ _). - + inv H1; constructor. - + constructor. - - (* extfs *) - - unfold extfs, eval_static_extfs. - destruct (is_bitfield _ _). - + inv H1; constructor. - + constructor. - - (* extfzl *) - - unfold extfzl, eval_static_extfzl. - destruct (is_bitfieldl _ _). - + inv H1; constructor. - + constructor. - - (* extfsl *) - - unfold extfsl, eval_static_extfsl. - destruct (is_bitfieldl _ _). - + inv H1; constructor. - + constructor. - - (* insf *) - - unfold insf, eval_static_insf. - destruct (is_bitfield _ _). - + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. - + constructor. - (* insfl *) - - unfold insfl, eval_static_insfl. - destruct (is_bitfieldl _ _). - + inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor. - + constructor. - (* select *) - - apply select_sound; auto. eapply eval_static_condition0_sound; eauto. - (* select imm *) - - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. - (* select long imm *) - - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto. -Qed. - -End SOUNDNESS. - diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v deleted file mode 100644 index 0b1c502d..00000000 --- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v +++ /dev/null @@ -1,452 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Syntax and Sequential Semantics of Abstract Basic Blocks. -*) -Require Import Setoid. -Require Import ImpPrelude. - -Module Type PseudoRegisters. - -Parameter t: Type. - -Parameter eq_dec: forall (x y: t), { x = y } + { x<>y }. - -End PseudoRegisters. - - -(** * Parameters of the language of Basic Blocks *) -Module Type LangParam. - -Declare Module R: PseudoRegisters. - -Parameter value: Type. - -(** Declare the type of operations *) - -Parameter op: Type. (* type of operations *) - -Parameter genv: Type. (* environment to be used for evaluating an op *) - -Parameter op_eval: genv -> op -> list value -> option value. - -End LangParam. - - - -(** * Syntax and (sequential) semantics of "basic blocks" *) -Module MkSeqLanguage(P: LangParam). - -Export P. - -Local Open Scope list. - -Section SEQLANG. - -Variable ge: genv. - -Definition mem := R.t -> value. - -Definition assign (m: mem) (x:R.t) (v: value): mem - := fun y => if R.eq_dec x y then v else m y. - - -(** expressions *) - -Inductive exp := - | PReg (x:R.t) - | Op (o:op) (le: list_exp) - | Old (e: exp) -with list_exp := - | Enil - | Econs (e:exp) (le:list_exp) - | LOld (le: list_exp) -. - -Fixpoint exp_eval (e: exp) (m old: mem): option value := - match e with - | PReg x => Some (m x) - | Op o le => - match list_exp_eval le m old with - | Some lv => op_eval ge o lv - | _ => None - end - | Old e => exp_eval e old old - end -with list_exp_eval (le: list_exp) (m old: mem): option (list value) := - match le with - | Enil => Some nil - | Econs e le' => - match exp_eval e m old, list_exp_eval le' m old with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end - | LOld le => list_exp_eval le old old - end. - -Definition inst := list (R.t * exp). (* = a sequence of assignments *) - -Fixpoint inst_run (i: inst) (m old: mem): option mem := - match i with - | nil => Some m - | (x, e)::i' => - match exp_eval e m old with - | Some v' => inst_run i' (assign m x v') old - | None => None - end - end. - -Definition bblock := list inst. - -Fixpoint run (p: bblock) (m: mem): option mem := - match p with - | nil => Some m - | i::p' => - match inst_run i m m with - | Some m' => run p' m' - | None => None - end - end. - -(* A few useful lemma *) -Lemma assign_eq m x v: - (assign m x v) x = v. -Proof. - unfold assign. destruct (R.eq_dec x x); try congruence. -Qed. - -Lemma assign_diff m x y v: - x<>y -> (assign m x v) y = m y. -Proof. - unfold assign. destruct (R.eq_dec x y); try congruence. -Qed. - -Lemma assign_skips m x y: - (assign m x (m x)) y = m y. -Proof. - unfold assign. destruct (R.eq_dec x y); try congruence. -Qed. - -Lemma assign_swap m x1 v1 x2 v2 y: - x1 <> x2 -> (assign (assign m x1 v1) x2 v2) y = (assign (assign m x2 v2) x1 v1) y. -Proof. - intros; destruct (R.eq_dec x2 y). - - subst. rewrite assign_eq, assign_diff; auto. rewrite assign_eq; auto. - - rewrite assign_diff; auto. - destruct (R.eq_dec x1 y). - + subst; rewrite! assign_eq. auto. - + rewrite! assign_diff; auto. -Qed. - - -(** A small theory of bblock simulation *) - -(* equalities on bblock outputs *) -Definition res_eq (om1 om2: option mem): Prop := - match om1 with - | Some m1 => exists m2, om2 = Some m2 /\ forall x, m1 x = m2 x - | None => om2 = None - end. - -Scheme exp_mut := Induction for exp Sort Prop -with list_exp_mut := Induction for list_exp Sort Prop. - -Lemma exp_equiv e old1 old2: - (forall x, old1 x = old2 x) -> - forall m1 m2, (forall x, m1 x = m2 x) -> - (exp_eval e m1 old1) = (exp_eval e m2 old2). -Proof. - intros H1. - induction e using exp_mut with (P0:=fun l => forall m1 m2, (forall x, m1 x = m2 x) -> list_exp_eval l m1 old1 = list_exp_eval l m2 old2); simpl; try congruence; auto. - - intros; erewrite IHe; eauto. - - intros; erewrite IHe, IHe0; auto. -Qed. - -Definition bblock_simu (p1 p2: bblock): Prop - := forall m, (run p1 m) <> None -> res_eq (run p1 m) (run p2 m). - -Lemma inst_equiv_refl i old1 old2: - (forall x, old1 x = old2 x) -> - forall m1 m2, (forall x, m1 x = m2 x) -> - res_eq (inst_run i m1 old1) (inst_run i m2 old2). -Proof. - intro H; induction i as [ | [x e]]; simpl; eauto. - intros m1 m2 H1. erewrite exp_equiv; eauto. - destruct (exp_eval e m2 old2); simpl; auto. - apply IHi. - unfold assign; intro y. destruct (R.eq_dec x y); auto. -Qed. - -Lemma bblock_equiv_refl p: forall m1 m2, (forall x, m1 x = m2 x) -> res_eq (run p m1) (run p m2). -Proof. - induction p as [ | i p']; simpl; eauto. - intros m1 m2 H; lapply (inst_equiv_refl i m1 m2); auto. - intros X; lapply (X m1 m2); auto; clear X. - destruct (inst_run i m1 m1); simpl. - - intros [m3 [H1 H2]]; rewrite H1; simpl; auto. - - intros H1; rewrite H1; simpl; auto. -Qed. - -Lemma res_eq_sym om1 om2: res_eq om1 om2 -> res_eq om2 om1. -Proof. - destruct om1; simpl. - - intros [m2 [H1 H2]]; subst; simpl. eauto. - - intros; subst; simpl; eauto. -Qed. - -Lemma res_eq_trans (om1 om2 om3: option mem): - (res_eq om1 om2) -> (res_eq om2 om3) -> (res_eq om1 om3). -Proof. - destruct om1; simpl. - - intros [m2 [H1 H2]]; subst; simpl. - intros [m3 [H3 H4]]; subst; simpl. - eapply ex_intro; intuition eauto. rewrite H2; auto. - - intro; subst; simpl; auto. -Qed. - -Lemma bblock_simu_alt p1 p2: bblock_simu p1 p2 <-> (forall m1 m2, (forall x, m1 x = m2 x) -> (run p1 m1)<>None -> res_eq (run p1 m1) (run p2 m2)). -Proof. - unfold bblock_simu; intuition. - intros; eapply res_eq_trans. eauto. - eapply bblock_equiv_refl; eauto. -Qed. - - -Lemma run_app p1: forall m1 p2, - run (p1++p2) m1 = - match run p1 m1 with - | Some m2 => run p2 m2 - | None => None - end. -Proof. - induction p1; simpl; try congruence. - intros; destruct (inst_run _ _ _); simpl; auto. -Qed. - -Lemma run_app_None p1 m1 p2: - run p1 m1 = None -> - run (p1++p2) m1 = None. -Proof. - intro H; rewrite run_app. rewrite H; auto. -Qed. - -Lemma run_app_Some p1 m1 m2 p2: - run p1 m1 = Some m2 -> - run (p1++p2) m1 = run p2 m2. -Proof. - intros H; rewrite run_app. rewrite H; auto. -Qed. - -End SEQLANG. - -Module Terms. - -(** terms in the symbolic evaluation -NB: such a term represents the successive computations in one given pseudo-register -*) - -Inductive term := - | Input (x:R.t) (hid:hashcode) - | App (o: op) (l: list_term) (hid:hashcode) -with list_term := - | LTnil (hid:hashcode) - | LTcons (t:term) (l:list_term) (hid:hashcode) - . - -Scheme term_mut := Induction for term Sort Prop -with list_term_mut := Induction for list_term Sort Prop. - -Bind Scope pattern_scope with term. -Delimit Scope term_scope with term. -Delimit Scope pattern_scope with pattern. - -Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope. -Notation "[ x ]" := (LTcons x [] _): pattern_scope. -Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope. -Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope. - -Import HConsingDefs. - -Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope. -Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope. -Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope. -Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope. - -Local Open Scope pattern_scope. - -Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := - match t with - | Input x _ => Some (m x) - | o @ l => - match list_term_eval ge l m with - | Some v => op_eval ge o v - | _ => None - end - end -with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := - match l with - | [] => Some nil - | LTcons t l' _ => - match term_eval ge t m, list_term_eval ge l' m with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end - end. - - -Definition term_get_hid (t: term): hashcode := - match t with - | Input _ hid => hid - | App _ _ hid => hid - end. - -Definition list_term_get_hid (l: list_term): hashcode := - match l with - | LTnil hid => hid - | LTcons _ _ hid => hid - end. - - -Fixpoint allvalid ge (l: list term) m : Prop := - match l with - | nil => True - | t::nil => term_eval ge t m <> None - | t::l' => term_eval ge t m <> None /\ allvalid ge l' m - end. - -Lemma allvalid_extensionality ge (l: list term) m: - allvalid ge l m <-> (forall t, List.In t l -> term_eval ge t m <> None). -Proof. - induction l as [|t l]; simpl; try (tauto). - destruct l. - - intuition (congruence || eauto). - - rewrite IHl; clear IHl. intuition (congruence || eauto). -Qed. - -Record pseudo_term: Type := intro_fail { - mayfail: list term; - effect: term -}. - -Lemma inf_option_equivalence (A:Type) (o1 o2: option A): - (o1 <> None -> o1 = o2) <-> (forall m1, o1 = Some m1 -> o2 = Some m1). -Proof. - destruct o1; intuition (congruence || eauto). - symmetry; eauto. -Qed. - -Definition match_pt (t: term) (pt: pseudo_term) := - (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m) - /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1). - -Lemma intro_fail_correct (l: list term) (t: term) : - (forall ge m, term_eval ge t m <> None <-> allvalid ge l m) -> match_pt t (intro_fail l t). -Proof. - unfold match_pt; simpl; intros; intuition congruence. -Qed. -Hint Resolve intro_fail_correct: wlp. - -Definition identity_fail (t: term):= intro_fail [t] t. - -Lemma identity_fail_correct (t: term): match_pt t (identity_fail t). -Proof. - eapply intro_fail_correct; simpl; tauto. -Qed. -Global Opaque identity_fail. -Hint Resolve identity_fail_correct: wlp. - -Definition nofail (is_constant: op -> bool) (t: term):= - match t with - | Input x _ => intro_fail ([])%list t - | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t) - | _ => identity_fail t - end. - -Lemma nofail_correct (is_constant: op -> bool) t: - (forall ge o, is_constant o = true -> op_eval ge o nil <> None) -> match_pt t (nofail is_constant t). -Proof. - destruct t; simpl. - + intros; eapply intro_fail_correct; simpl; intuition congruence. - + intros; destruct l; simpl; auto with wlp. - destruct (is_constant o) eqn:Heqo; simpl; intuition eauto with wlp. - eapply intro_fail_correct; simpl; intuition eauto with wlp. -Qed. -Global Opaque nofail. -Hint Resolve nofail_correct: wlp. - -Definition term_equiv t1 t2:= forall ge m, term_eval ge t1 m = term_eval ge t2 m. - -Global Instance term_equiv_Equivalence : Equivalence term_equiv. -Proof. - split; intro x; unfold term_equiv; intros; eauto. - eapply eq_trans; eauto. -Qed. - -Lemma match_pt_term_equiv t1 t2 pt: term_equiv t1 t2 -> match_pt t1 pt -> match_pt t2 pt. -Proof. - unfold match_pt, term_equiv. - intros H. intuition; try (erewrite <- H1 in * |- *; congruence). - erewrite <- H2; eauto; congruence. -Qed. -Hint Resolve match_pt_term_equiv: wlp. - -Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term := - {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}. - -Lemma app_fail_allvalid_correct l pt t1 t2: forall - (V1: forall (ge : genv) (m : mem), term_eval ge t1 m <> None <-> allvalid ge (mayfail pt) m) - (V2: forall (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail {| mayfail := t1 :: l; effect := t1 |}) m) - (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail (app_fail l pt)) m. -Proof. - intros; generalize (V1 ge m) (V2 ge m); rewrite !allvalid_extensionality; simpl. clear V1 V2. - intuition subst. - + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto. - + eapply H3; eauto. - intros. intuition subst. - * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto. - * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto. -Qed. -Local Hint Resolve app_fail_allvalid_correct: core. - -Lemma app_fail_correct l pt t1 t2: - match_pt t1 pt -> - match_pt t2 {| mayfail:=t1::l; effect:=t1 |} -> - match_pt t2 (app_fail l pt). -Proof. - unfold match_pt in * |- *; intros (V1 & E1) (V2 & E2); split; intros ge m; try (eauto; fail). -Qed. -Extraction Inline app_fail. - -Import ImpCore.Notations. -Local Open Scope impure_scope. - -Record reduction:= { - result:> term -> ?? pseudo_term; - result_correct: forall t, WHEN result t ~> pt THEN match_pt t pt; -}. -Hint Resolve result_correct: wlp. - -End Terms. - -End MkSeqLanguage. - - -Module Type SeqLanguage. - -Declare Module LP: LangParam. - -Include MkSeqLanguage LP. - -End SeqLanguage. - diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v deleted file mode 100644 index c914eee1..00000000 --- a/mppa_k1c/abstractbb/ImpSimuTest.v +++ /dev/null @@ -1,1258 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* *) -(* Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks - -with imperative hash-consing, and rewriting. - -*) - -Require Export Impure.ImpHCons. -Export Notations. -Import HConsing. - - -Require Export SeqSimuTheory. - -Require Import PArith. - - -Local Open Scope impure. - -Import ListNotations. -Local Open Scope list_scope. - - -Module Type ImpParam. - -Include LangParam. - -Parameter op_eq: op -> op -> ?? bool. - -Parameter op_eq_correct: forall o1 o2, - WHEN op_eq o1 o2 ~> b THEN - b=true -> o1 = o2. - -End ImpParam. - - -Module Type ISeqLanguage. - -Declare Module LP: ImpParam. - -Include MkSeqLanguage LP. - -End ISeqLanguage. - - -Module Type ImpDict. - -Declare Module R: PseudoRegisters. - -Parameter t: Type -> Type. - -Parameter get: forall {A}, t A -> R.t -> option A. - -Parameter set: forall {A}, t A -> R.t -> A -> t A. - -Parameter set_spec_eq: forall A d x (v: A), - get (set d x v) x = Some v. - -Parameter set_spec_diff: forall A d x y (v: A), - x <> y -> get (set d x v) y = get d y. - -Parameter rem: forall {A}, t A -> R.t -> t A. - -Parameter rem_spec_eq: forall A (d: t A) x, - get (rem d x) x = None. - -Parameter rem_spec_diff: forall A (d: t A) x y, - x <> y -> get (rem d x) y = get d y. - -Parameter empty: forall {A}, t A. - -Parameter empty_spec: forall A x, - get (empty (A:=A)) x = None. - -Parameter eq_test: forall {A}, t A -> t A -> ?? bool. - -Parameter eq_test_correct: forall A (d1 d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. - -(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *) - - -(* only for debugging *) -Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t. - -End ImpDict. - - -Module Type ImpSimuInterface. - -Declare Module CoreL: ISeqLanguage. -Import CoreL. -Import Terms. - -Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool. - -Parameter bblock_simu_test_correct: forall reduce (p1 p2 : bblock), - WHEN bblock_simu_test reduce p1 p2 ~> b - THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. - - -Parameter verb_bblock_simu_test - : reduction -> - (R.t -> ?? pstring) -> - (op -> ?? pstring) -> bblock -> bblock -> ?? bool. - -Parameter verb_bblock_simu_test_correct: - forall reduce - (string_of_name : R.t -> ?? pstring) - (string_of_op : op -> ?? pstring) - (p1 p2 : bblock), - WHEN verb_bblock_simu_test reduce string_of_name string_of_op p1 p2 ~> b - THEN b = true -> forall ge : genv, bblock_simu ge p1 p2. - -End ImpSimuInterface. - - - -Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuInterface with Module CoreL := L. - -Module CoreL:=L. - -Module ST := SimuTheory L. - -Import ST. -Import Terms. - -Definition term_set_hid (t: term) (hid: hashcode): term := - match t with - | Input x _ => Input x hid - | App op l _ => App op l hid - end. - -Definition list_term_set_hid (l: list_term) (hid: hashcode): list_term := - match l with - | LTnil _ => LTnil hid - | LTcons t l' _ => LTcons t l' hid - end. - -Lemma term_eval_set_hid ge t hid m: - term_eval ge (term_set_hid t hid) m = term_eval ge t m. -Proof. - destruct t; simpl; auto. -Qed. - -Lemma list_term_eval_set_hid ge l hid m: - list_term_eval ge (list_term_set_hid l hid) m = list_term_eval ge l m. -Proof. - destruct l; simpl; auto. -Qed. - -(* Local nickname *) -Module D:=ImpPrelude.Dict. - -Section SimuWithReduce. - -Variable reduce: reduction. - -Section CanonBuilding. - -Variable hC_term: hashinfo term -> ?? term. -Hypothesis hC_term_correct: forall t, WHEN hC_term t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. - -Variable hC_list_term: hashinfo list_term -> ?? list_term. -Hypothesis hC_list_term_correct: forall t, WHEN hC_list_term t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. - -(* First, we wrap constructors for hashed values !*) - -Local Open Scope positive. -Local Open Scope list_scope. - -Definition hInput_hcodes (x:R.t) := - DO hc <~ hash 1;; - DO hv <~ hash x;; - RET [hc;hv]. -Extraction Inline hInput_hcodes. - -Definition hInput (x:R.t): ?? term := - DO hv <~ hInput_hcodes x;; - hC_term {| hdata:=Input x unknown_hid; hcodes :=hv; |}. - -Lemma hInput_correct x: - WHEN hInput x ~> t THEN forall ge m, term_eval ge t m = Some (m x). -Proof. - wlp_simplify. -Qed. -Global Opaque hInput. -Hint Resolve hInput_correct: wlp. - -Definition hApp_hcodes (o:op) (l: list_term) := - DO hc <~ hash 2;; - DO hv <~ hash o;; - RET [hc;hv;list_term_get_hid l]. -Extraction Inline hApp_hcodes. - -Definition hApp (o:op) (l: list_term) : ?? term := - DO hv <~ hApp_hcodes o l;; - hC_term {| hdata:=App o l unknown_hid; hcodes:=hv |}. - -Lemma hApp_correct o l: - WHEN hApp o l ~> t THEN forall ge m, - term_eval ge t m = match list_term_eval ge l m with - | Some v => op_eval ge o v - | None => None - end. -Proof. - wlp_simplify. -Qed. -Global Opaque hApp. -Hint Resolve hApp_correct: wlp. - -Definition hLTnil (_: unit): ?? list_term := - hC_list_term {| hdata:=LTnil unknown_hid; hcodes := nil; |} . - -Lemma hLTnil_correct x: - WHEN hLTnil x ~> l THEN forall ge m, list_term_eval ge l m = Some nil. -Proof. - wlp_simplify. -Qed. -Global Opaque hLTnil. -Hint Resolve hLTnil_correct: wlp. - - -Definition hLTcons (t: term) (l: list_term): ?? list_term := - hC_list_term {| hdata:=LTcons t l unknown_hid; hcodes := [term_get_hid t; list_term_get_hid l]; |}. - -Lemma hLTcons_correct t l: - WHEN hLTcons t l ~> l' THEN forall ge m, - list_term_eval ge l' m = match term_eval ge t m, list_term_eval ge l m with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end. -Proof. - wlp_simplify. -Qed. -Global Opaque hLTcons. -Hint Resolve hLTcons_correct: wlp. - -(* Second, we use these hashed constructors ! *) - -Record hsmem:= {hpre: list term; hpost:> Dict.t term}. - -(** evaluation of the post-condition *) -Definition hsmem_post_eval ge (hd: Dict.t term) x (m:mem) := - match Dict.get hd x with - | None => Some (m x) - | Some ht => term_eval ge ht m - end. - -Definition hsmem_get (d:hsmem) x: ?? term := - match Dict.get d x with - | None => hInput x - | Some t => RET t - end. - -Lemma hsmem_get_correct (d:hsmem) x: - WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = hsmem_post_eval ge d x m. -Proof. - unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify. -Qed. -Global Opaque hsmem_get. -Hint Resolve hsmem_get_correct: wlp. - -Local Opaque allvalid. - -Definition smem_model ge (d: smem) (hd:hsmem): Prop := - (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m) - /\ (forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m = (ST.term_eval ge (d x) m)). - -Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd -> - forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m <> None. -Proof. - intros (H1 & H2) m x H. rewrite H2; auto. - unfold smem_valid in H. intuition eauto. -Qed. - -Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd -> - forall m x, allvalid ge hd.(hpre) m -> hsmem_post_eval ge hd x m <> None. -Proof. - intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt. - - split; eauto. - - rewrite <- H1; auto. -Qed. - -Definition naive_set (hd:hsmem) x (t:term) := - {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}. - -Lemma naive_set_correct hd x ht ge d t: - smem_model ge d hd -> - (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> - smem_model ge (smem_set d x t) (naive_set hd x ht). -Proof. - unfold naive_set; intros (DM0 & DM1) EQT; split. - - intros m. - destruct (DM0 m) as (PRE & VALID0); clear DM0. - assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. } - assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, ST.term_eval ge (d x) m <> None). { unfold smem_valid in PRE; tauto. } - rewrite !allvalid_extensionality in * |- *; simpl. - intuition (subst; eauto). - + eapply smem_valid_set_proof; eauto. - erewrite <- EQT; eauto. - + exploit smem_valid_set_decompose_1; eauto. - intros X1; exploit smem_valid_set_decompose_2; eauto. - rewrite <- EQT; eauto. - + exploit smem_valid_set_decompose_1; eauto. - - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl. - Local Hint Resolve smem_valid_set_decompose_1: core. - intros; case (R.eq_dec x x0). - + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto. - + intros; rewrite !Dict.set_spec_diff; simpl; eauto. -Qed. -Local Hint Resolve naive_set_correct: core. - -Definition equiv_hsmem ge (hd1 hd2: hsmem) := - (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m) - /\ (forall m x, allvalid ge hd1.(hpre) m -> hsmem_post_eval ge hd1 x m = hsmem_post_eval ge hd2 x m). - -Lemma equiv_smem_symmetry ge hd1 hd2: - equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1. -Proof. - intros (V1 & P1); split. - - intros; symmetry; auto. - - intros; symmetry; eapply P1. rewrite V1; auto. -Qed. - -Lemma equiv_hsmem_models ge hd1 hd2 d: - smem_model ge d hd1 -> equiv_hsmem ge hd1 hd2 -> smem_model ge d hd2. -Proof. - intros (VALID & EQUIV) (HEQUIV & PEQUIV); split. - - intros m; rewrite <- VALID; auto. symmetry; auto. - - intros m x H. rewrite <- EQUIV; auto. - rewrite PEQUIV; auto. - rewrite VALID; auto. -Qed. - -Variable log_assign: R.t -> term -> ?? unit. - -Definition lift {A B} hid (x:A) (k: B -> ?? A) (y:B): ?? A := - DO b <~ phys_eq hid unknown_hid;; - if b then k y else RET x. - -Fixpoint hterm_lift (t: term): ?? term := - match t with - | Input x hid => lift hid t hInput x - | App o l hid => - lift hid t - (fun l => DO lt <~ hlist_term_lift l;; - hApp o lt) l - end -with hlist_term_lift (l: list_term) {struct l}: ?? list_term := - match l with - | LTnil hid => lift hid l hLTnil () - | LTcons t l' hid => - lift hid l - (fun t => DO t <~ hterm_lift t;; - DO lt <~ hlist_term_lift l';; - hLTcons t lt) t - end. - -Lemma hterm_lift_correct t: - WHEN hterm_lift t ~> ht THEN forall ge m, term_eval ge ht m = term_eval ge t m. -Proof. - induction t using term_mut with (P0:=fun lt => - WHEN hlist_term_lift lt ~> hlt THEN forall ge m, list_term_eval ge hlt m = list_term_eval ge lt m); - wlp_simplify. - - rewrite H0, H; auto. - - rewrite H1, H0, H; auto. -Qed. -Local Hint Resolve hterm_lift_correct: wlp. -Global Opaque hterm_lift. - -Variable log_new_hterm: term -> ?? unit. - -Fixpoint hterm_append (l: list term) (lh: list term): ?? list term := - match l with - | nil => RET lh - | t::l' => - DO ht <~ hterm_lift t;; - log_new_hterm ht;; - hterm_append l' (ht::lh) - end. - -Lemma hterm_append_correct l: forall lh, - WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)). -Proof. - Local Hint Resolve eq_trans: localhint. - induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp). - - intros; rewrite! allvalid_extensionality; intuition eauto. - - intros REC ge m; rewrite REC; clear IHl' REC. rewrite !allvalid_extensionality. - simpl; intuition (subst; eauto with wlp localhint). -Qed. -(*Local Hint Resolve hterm_append_correct: wlp.*) -Global Opaque hterm_append. - -Definition smart_set (hd:hsmem) x (ht:term) := - match ht with - | Input y _ => - if R.eq_dec x y then - RET (Dict.rem hd x) - else ( - log_assign x ht;; - RET (Dict.set hd x ht) - ) - | _ => - log_assign x ht;; - RET (Dict.set hd x ht) - end. - -Lemma smart_set_correct hd x ht: - WHEN smart_set hd x ht ~> d THEN - forall ge m y, hsmem_post_eval ge d y m = hsmem_post_eval ge (Dict.set hd x ht) y m. -Proof. - destruct ht; wlp_simplify. - unfold hsmem_post_eval; simpl. case (R.eq_dec x0 y). - - intros; subst. rewrite Dict.set_spec_eq, Dict.rem_spec_eq. simpl; congruence. - - intros; rewrite Dict.set_spec_diff, Dict.rem_spec_diff; auto. -Qed. -(*Local Hint Resolve smart_set_correct: wlp.*) -Global Opaque smart_set. - -Definition hsmem_set (hd:hsmem) x (t:term) := - DO pt <~ reduce t;; - DO lht <~ hterm_append pt.(mayfail) hd.(hpre);; - DO ht <~ hterm_lift pt.(effect);; - log_new_hterm ht;; - DO nd <~ smart_set hd x ht;; - RET {| hpre := lht; hpost := nd |}. - -Lemma hsmem_set_correct hd x ht: - WHEN hsmem_set hd x ht ~> nhd THEN - forall ge d t, smem_model ge d hd -> - (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) -> - smem_model ge (smem_set d x t) nhd. -Proof. - intros; wlp_simplify. - generalize (hterm_append_correct _ _ _ Hexta0); intro APPEND. - generalize (hterm_lift_correct _ _ Hexta1); intro LIFT. - generalize (smart_set_correct _ _ _ _ Hexta3); intro SMART. - eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl. - destruct H as (VALID & EFFECT); split. - - intros; rewrite APPEND, <- VALID. - rewrite !allvalid_extensionality in * |- *; simpl; intuition (subst; eauto). - - intros m x0 ALLVALID; rewrite SMART. - destruct (term_eval ge ht m) eqn: Hht. - * case (R.eq_dec x x0). - + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq. - erewrite LIFT, EFFECT; eauto. - + intros; unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_diff; auto. - * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto. -Qed. -Local Hint Resolve hsmem_set_correct: wlp. -Global Opaque hsmem_set. - -(* VARIANTE: we do not hash-cons the term from the expression -Lemma exp_hterm_correct ge e hod od: - smem_model ge od hod -> - forall hd d, - smem_model ge d hd -> - forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m. -Proof. - intro H. - induction e using exp_mut with (P0:=fun le => forall d hd, - smem_model ge d hd -> forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m); - unfold smem_model in * |- * ; simpl; intuition eauto. - - erewrite IHe; eauto. - - erewrite IHe0, IHe; eauto. -Qed. -Local Hint Resolve exp_hterm_correct: wlp. -*) - -Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term := - match e with - | PReg x => hsmem_get hd x - | Op o le => - DO lt <~ list_exp_hterm le hd hod;; - hApp o lt - | Old e => exp_hterm e hod hod - end -with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term := - match le with - | Enil => hLTnil tt - | Econs e le' => - DO t <~ exp_hterm e hd hod;; - DO lt <~ list_exp_hterm le' hd hod;; - hLTcons t lt - | LOld le => list_exp_hterm le hod hod - end. - -Lemma exp_hterm_correct_x ge e hod od: - smem_model ge od hod -> - forall hd d, - smem_model ge d hd -> - WHEN exp_hterm e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. - Proof. - intro H. - induction e using exp_mut with (P0:=fun le => forall d hd, - smem_model ge d hd -> - WHEN list_exp_hterm le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = ST.list_term_eval ge (list_exp_term le d od) m); - unfold smem_model, hsmem_post_eval in * |- * ; simpl; wlp_simplify. - - rewrite H1, <- H4; auto. - - rewrite H4, <- H0; simpl; auto. - - rewrite H5, <- H0, <- H4; simpl; auto. -Qed. -Global Opaque exp_hterm. - -Lemma exp_hterm_correct e hd hod: - WHEN exp_hterm e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m. -Proof. - unfold wlp; intros; eapply exp_hterm_correct_x; eauto. -Qed. -Hint Resolve exp_hterm_correct: wlp. - -Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem := - match i with - | nil => RET hd - | (x, e)::i' => - DO ht <~ exp_hterm e hd hod;; - DO nd <~ hsmem_set hd x ht;; - hinst_smem i' nd hod - end. - -Lemma hinst_smem_correct i: forall hd hod, - WHEN hinst_smem i hd hod ~> hd' THEN - forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'. -Proof. - Local Hint Resolve smem_valid_set_proof: core. - induction i; simpl; wlp_simplify; eauto 15 with wlp. -Qed. -Global Opaque hinst_smem. -Local Hint Resolve hinst_smem_correct: wlp. - -(* logging info: we log the number of inst-instructions passed ! *) -Variable log_new_inst: unit -> ?? unit. - -Fixpoint bblock_hsmem_rec (p: bblock) (d: hsmem): ?? hsmem := - match p with - | nil => RET d - | i::p' => - log_new_inst tt;; - DO d' <~ hinst_smem i d d;; - bblock_hsmem_rec p' d' - end. - -Lemma bblock_hsmem_rec_correct p: forall hd, - WHEN bblock_hsmem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'. -Proof. - induction p; simpl; wlp_simplify. -Qed. -Global Opaque bblock_hsmem_rec. -Local Hint Resolve bblock_hsmem_rec_correct: wlp. - -Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}. - -Lemma hsmem_empty_correct ge: smem_model ge smem_empty hsmem_empty. -Proof. - unfold smem_model, smem_valid, hsmem_post_eval; simpl; intuition try congruence. - rewrite !Dict.empty_spec; simpl; auto. -Qed. - -Definition bblock_hsmem: bblock -> ?? hsmem - := fun p => bblock_hsmem_rec p hsmem_empty. - -Lemma bblock_hsmem_correct p: - WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd. -Proof. - Local Hint Resolve hsmem_empty_correct: core. - wlp_simplify. -Qed. -Global Opaque bblock_hsmem. - -End CanonBuilding. - -(* Now, we build the hash-Cons value from a "hash_eq". - -Informal specification: - [hash_eq] must be consistent with the "hashed" constructors defined above. - -We expect that hashinfo values in the code of these "hashed" constructors verify: - - (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y) - -*) - -Definition term_hash_eq (ta tb: term): ?? bool := - match ta, tb with - | Input xa _, Input xb _ => - if R.eq_dec xa xb (* Inefficient in some cases ? *) - then RET true - else RET false - | App oa lta _, App ob ltb _ => - DO b <~ op_eq oa ob ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Lemma term_hash_eq_correct: forall ta tb, WHEN term_hash_eq ta tb ~> b THEN b=true -> term_set_hid ta unknown_hid=term_set_hid tb unknown_hid. -Proof. - Local Hint Resolve op_eq_correct: wlp. - destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque term_hash_eq. -Hint Resolve term_hash_eq_correct: wlp. - -Definition list_term_hash_eq (lta ltb: list_term): ?? bool := - match lta, ltb with - | LTnil _, LTnil _ => RET true - | LTcons ta lta _, LTcons tb ltb _ => - DO b <~ phys_eq ta tb ;; - if b then phys_eq lta ltb - else RET false - | _,_ => RET false - end. - -Lemma list_term_hash_eq_correct: forall lta ltb, WHEN list_term_hash_eq lta ltb ~> b THEN b=true -> list_term_set_hid lta unknown_hid=list_term_set_hid ltb unknown_hid. -Proof. - destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)). -Qed. -Global Opaque list_term_hash_eq. -Hint Resolve list_term_hash_eq_correct: wlp. - -Lemma hsmem_post_eval_intro (d1 d2: hsmem): - (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, hsmem_post_eval ge d1 x m = hsmem_post_eval ge d2 x m). -Proof. - unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto. -Qed. - -Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp. - -Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term := - {| - Dict.test_eq := phys_eq; - Dict.hashing := fun (ht: term) => RET (term_get_hid ht); - Dict.log := log |}. -Obligation 1. - eauto with wlp. -Qed. - -(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***) -Definition no_log_assign (x:R.t) (t:term): ?? unit := RET tt. -Definition no_log_new_term (t:term): ?? unit := RET tt. - -Section Prog_Eq_Gen. - -Variable log_assign: R.t -> term -> ?? unit. -Variable log_new_term: hashConsing term -> hashConsing list_term -> ??(term -> ?? unit). -Variable log_inst1: unit -> ?? unit. (* log of p1 insts *) -Variable log_inst2: unit -> ?? unit. (* log of p2 insts *) - -Variable hco_term: hashConsing term. -Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m. - -Variable hco_list: hashConsing list_term. -Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m. - -Variable print_error_end: hsmem -> hsmem -> ?? unit. -Variable print_error: pstring -> ?? unit. - -Variable check_failpreserv: bool. -Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *) - -Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool := - DO failure_in_failpreserv <~ make_cref false;; - DO r <~ (TRY - DO d1 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;; - DO log_new_term <~ log_new_term hco_term hco_list;; - DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;; - DO b <~ Dict.eq_test d1 d2 ;; - if b then ( - if check_failpreserv then ( - let hp := mk_hash_params dbg_failpreserv in - failure_in_failpreserv.(set)(true);; - Sets.assert_list_incl hp d2.(hpre) d1.(hpre);; - RET true - ) else RET false - ) else ( - print_error_end d1 d2 ;; - RET false - ) - CATCH_FAIL s, _ => - DO b <~ failure_in_failpreserv.(get)();; - if b then RET false - else print_error s;; RET false - ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));; - RET (`r). -Obligation 1. - constructor 1; wlp_simplify; try congruence. - destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0. - apply bblock_smem_simu; auto. split. - + intros m; rewrite <- EQPRE1, <- EQPRE2. - rewrite ! allvalid_extensionality. - unfold incl in * |- *; intuition eauto. - + intros m0 x VALID; rewrite <- EQPOST1, <- EQPOST2; auto. - erewrite hsmem_post_eval_intro; eauto. - erewrite <- EQPRE2; auto. - erewrite <- EQPRE1 in VALID. - rewrite ! allvalid_extensionality in * |- *. - unfold incl in * |- *; intuition eauto. -Qed. - -Theorem g_bblock_simu_test_correct p1 p2: - WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. - destruct exta0; simpl in * |- *; auto. -Qed. -Global Opaque g_bblock_simu_test. - -End Prog_Eq_Gen. - - - -Definition hpt: hashP term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}. -Definition hplt: hashP list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}. - -Definition recover_hcodes (t:term): ??(hashinfo term) := - match t with - | Input x _ => - DO hv <~ hInput_hcodes x ;; - RET {| hdata := t; hcodes := hv |} - | App o l _ => - DO hv <~ hApp_hcodes o l ;; - RET {| hdata := t; hcodes := hv |} - end. - - -Definition msg_end_of_bblock: pstring :="--- unknown subterms in the graph". - -Definition log_new_term - (unknownHash_msg: term -> ?? pstring) - (hct:hashConsing term) - (hcl:hashConsing list_term) - : ?? (term -> ?? unit) := - DO clock <~ hct.(next_hid)();; - hct.(next_log) msg_end_of_bblock;; - hcl.(next_log) msg_end_of_bblock;; - RET (fun t => - DO ok <~ hash_older (term_get_hid t) clock;; - if ok - then - RET tt - else - DO ht <~ recover_hcodes t;; - hct.(remove) ht;; - DO msg <~ unknownHash_msg t;; - FAILWITH msg). - -Definition skip (_:unit): ?? unit := RET tt. - -Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ". -Definition msg_error_on_end: pstring := "mismatch in final assignments !". -Definition msg_unknow_term: pstring := "unknown term". -Definition msg_number: pstring := "on 2nd bblock -- on inst num ". -Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)". - -Definition print_error_end (_ _: hsmem): ?? unit - := println (msg_prefix +; msg_error_on_end). - -Definition print_error (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - println (msg_prefix +; msg_number +; n +; " -- " +; s). - -Definition failpreserv_error (_: term): ?? unit - := println (msg_prefix +; msg_notfailpreserv). - -Lemma term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: - term_set_hid t1 hid1 = term_set_hid t2 hid2 -> term_eval ge t1 m = term_eval ge t2 m. -Proof. - intro H; erewrite <- term_eval_set_hid; rewrite H. apply term_eval_set_hid. -Qed. - -Lemma list_term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m: - list_term_set_hid t1 hid1 = list_term_set_hid t2 hid2 -> list_term_eval ge t1 m = list_term_eval ge t2 m. -Proof. - intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid. -Qed. - -Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core. - -Program Definition bblock_simu_test (p1 p2: bblock): ?? bool := - DO log <~ count_logger ();; - DO hco_term <~ mk_annot (hCons hpt);; - DO hco_list <~ mk_annot (hCons hplt);; - g_bblock_simu_test - no_log_assign - (log_new_term (fun _ => RET msg_unknow_term)) - skip - (log_insert log) - hco_term _ - hco_list _ - print_error_end - (print_error log) - true (* check_failpreserv *) - failpreserv_error - p1 p2. -Obligation 1. - generalize (hCons_correct _ _ _ H0); clear H0. - wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ H); clear H. - wlp_simplify. -Qed. - -Local Hint Resolve g_bblock_simu_test_correct: core. - -Theorem bblock_simu_test_correct p1 p2: - WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque bblock_simu_test. - -(** This is only to print info on each bblock_simu_test run **) -Section Verbose_version. - -Variable string_of_name: R.t -> ?? pstring. -Variable string_of_op: op -> ?? pstring. - - -Local Open Scope string_scope. - -Definition string_term_hid (t: term): ?? pstring := - DO id <~ string_of_hashcode (term_get_hid t);; - RET ("E" +; (CamlStr id)). - -Definition string_list_hid (lt: list_term): ?? pstring := - DO id <~ string_of_hashcode (list_term_get_hid lt);; - RET ("L" +; (CamlStr id)). - -Definition print_raw_term (t: term): ?? unit := - match t with - | Input x _ => - DO s <~ string_of_name x;; - println( "init_access " +; s) - | App o (LTnil _) _ => - DO so <~ string_of_op o;; - println so - | App o l _ => - DO so <~ string_of_op o;; - DO sl <~ string_list_hid l;; - println (so +; " " +; sl) - end. - -(* -Definition print_raw_list(lt: list_term): ?? unit := - match lt with - | LTnil _=> println "" - | LTcons t l _ => - DO st <~ string_term_hid t;; - DO sl <~ string_list_hid l;; - println(st +; " " +; sl) - end. -*) - -Section PrettryPrint. - -Variable get_debug_info: term -> ?? option pstring. - -Fixpoint string_of_term (t: term): ?? pstring := - match t with - | Input x _ => string_of_name x - | App o (LTnil _) _ => string_of_op o - | App o l _ => - DO so <~ string_of_op o;; - DO sl <~ string_of_list_term l;; - RET (so +; "[" +; sl +; "]") - end -with string_of_list_term (l: list_term): ?? pstring := - match l with - | LTnil _ => RET (Str "") - | LTcons t (LTnil _) _ => - DO dbg <~ get_debug_info t;; - match dbg with - | Some x => RET x - | None => string_of_term t - end - | LTcons t l' _ => - DO st <~ (DO dbg <~ get_debug_info t;; - match dbg with - | Some x => RET x - | None => string_of_term t - end);; - DO sl <~ string_of_list_term l';; - RET (st +; ";" +; sl) - end. - - -End PrettryPrint. - - -Definition pretty_term gdi t := - DO r <~ string_of_term gdi t;; - println(r). - -Fixpoint print_head (head: list pstring): ?? unit := - match head with - | i::head' => println (i);; print_head head' - | _ => RET tt - end. - -Definition print_term gdi (head: list pstring) (t: term): ?? unit := - print_head head;; - DO s <~ string_term_hid t;; - print (s +; ": ");; - print_raw_term t;; - DO dbg <~ gdi t;; - match dbg with - | Some x => - print("// " +; x +; " <- ");; - pretty_term gdi t - | None => RET tt - end. - -Definition print_list gdi (head: list pstring) (lt: list_term): ?? unit := - print_head head;; - DO s <~ string_list_hid lt ;; - print (s +; ": ");; - (* print_raw_list lt;; *) - DO ps <~ string_of_list_term gdi lt;; - println("[" +; ps +; "]"). - - -Definition print_tables gdi ext exl: ?? unit := - println "-- term table --" ;; - iterall ext (fun head _ pt => print_term gdi head pt.(hdata));; - println "-- list table --" ;; - iterall exl (fun head _ pl => print_list gdi head pl.(hdata));; - println "----------------". - -Definition print_final_debug gdi (d1 d2: hsmem): ?? unit - := DO b <~ Dict.not_eq_witness d1 d2 ;; - match b with - | Some x => - DO s <~ string_of_name x;; - println("mismatch on: " +; s);; - match Dict.get d1 x with - | None => println("=> unassigned in 1st bblock") - | Some t1 => - print("=> node expected from 1st bblock: ");; - pretty_term gdi t1 - end;; - match Dict.get d2 x with - | None => println("=> unassigned in 2nd bblock") - | Some t2 => - print("=> node found from 2nd bblock: ");; - pretty_term gdi t2 - end - | None => FAILWITH "bug in Dict.not_eq_witness ?" - end. - -Definition witness:= option term. - -Definition msg_term (cr: cref witness) t := - set cr (Some t);; - RET msg_unknow_term. - -Definition print_witness gdi cr (*msg*) := - DO wit <~ get cr ();; - match wit with - | Some t => - println("=> unknown term node: ");; - pretty_term gdi t (*;; - println("=> encoded on " +; msg +; " graph as: ");; - print_raw_term t *) - | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)" - end. - - -Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables gdi ext exl;; - print_error_end d1 d2;; - print_final_debug gdi d1 d2. - -Definition print_error1 gdi hct hcl cr log s : ?? unit - := println "- GRAPH of 1st bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables gdi ext exl;; - print_error log s;; - print_witness gdi cr (*"1st"*). - - -Definition xmsg_number: pstring := "on 1st bblock -- on inst num ". - -Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit - := println (msg_prefix +; msg_error_on_end);; - println "- GRAPH of 2nd bblock";; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - print_tables gdi ext exl. - -Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit - := DO n <~ log_info log ();; - DO ext <~ export hct ();; - DO exl <~ export hcl ();; - println (msg_prefix +; xmsg_number +; n +; " -- " +; s);; - print_witness gdi cr (*"2nd"*);; - println "- GRAPH of 2nd bblock";; - print_tables gdi ext exl. - -(* USELESS -Definition simple_log_assign (d: D.t term pstring) (x: R.t) (t: term): ?? unit := - DO s <~ string_of_name x;; - d.(D.set) (t,s). -*) - -Definition log_assign (d: D.t term pstring) (log: logger unit) (x: R.t) (t: term): ?? unit := - DO i <~ log_info log ();; - DO sx <~ string_of_name x;; - d.(D.set) (t,(sx +; "@" +; i)). - -Definition msg_new_inst : pstring := "--- inst ". - -Definition hlog (log: logger unit) (hct: hashConsing term) (hcl: hashConsing list_term): unit -> ?? unit := - (fun _ => - log_insert log tt ;; - DO s <~ log_info log tt;; - let s:= msg_new_inst +; s in - next_log hct s;; - next_log hcl s - ). - -Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool := - DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hpt);; - DO hco_list <~ mk_annot (hCons hplt);; - DO result1 <~ g_bblock_simu_test - (log_assign dict_info log1) - (log_new_term (msg_term cr)) - (hlog log1 hco_term hco_list) - (log_insert log2) - hco_term _ - hco_list _ - (print_error_end1 dict_info.(D.get) hco_term hco_list) - (print_error1 dict_info.(D.get) hco_term hco_list cr log2) - true - failpreserv_error - p1 p2;; - if result1 - then RET true - else - DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));; - DO log1 <~ count_logger ();; - DO log2 <~ count_logger ();; - DO cr <~ make_cref None;; - DO hco_term <~ mk_annot (hCons hpt);; - DO hco_list <~ mk_annot (hCons hplt);; - DO result2 <~ g_bblock_simu_test - (log_assign dict_info log1) - (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *) - (log_new_term (msg_term cr)) (* REM: too strong ?? *) - (hlog log1 hco_term hco_list) - (log_insert log2) - hco_term _ - hco_list _ - (print_error_end2 dict_info.(D.get) hco_term hco_list) - (print_error2 dict_info.(D.get) hco_term hco_list cr log2) - false - (fun _ => RET tt) - p2 p1;; - if result2 - then ( - println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");; - RET false - ) else RET false - . -Obligation 1. - generalize (hCons_correct _ _ _ H0); clear H0. - wlp_simplify. -Qed. -Obligation 2. - generalize (hCons_correct _ _ _ H); clear H. - wlp_simplify. -Qed. -Obligation 3. - generalize (hCons_correct _ _ _ H0); clear H0. - wlp_simplify. -Qed. -Obligation 4. - generalize (hCons_correct _ _ _ H); clear H. - wlp_simplify. -Qed. - -Theorem verb_bblock_simu_test_correct p1 p2: - WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2. -Proof. - wlp_simplify. -Qed. -Global Opaque verb_bblock_simu_test. - -End Verbose_version. - -End SimuWithReduce. - -(* TODO: why inlining fails here ? *) -Transparent hterm_lift. -Extraction Inline lift. - -End ImpSimu. - -Require Import FMapPositive. - - -Require Import PArith. -Require Import FMapPositive. - -Module ImpPosDict <: ImpDict with Module R:=Pos. - -Module R:=Pos. - -Definition t:=PositiveMap.t. - -Definition get {A} (d:t A) (x:R.t): option A - := PositiveMap.find x d. - -Definition set {A} (d:t A) (x:R.t) (v:A): t A - := PositiveMap.add x v d. - -Local Hint Unfold PositiveMap.E.eq: core. - -Lemma set_spec_eq A d x (v: A): - get (set d x v) x = Some v. -Proof. - unfold get, set; apply PositiveMap.add_1; auto. -Qed. - -Lemma set_spec_diff A d x y (v: A): - x <> y -> get (set d x v) y = get d y. -Proof. - unfold get, set; intros; apply PositiveMap.gso; auto. -Qed. - -Definition rem {A} (d:t A) (x:R.t): t A - := PositiveMap.remove x d. - -Lemma rem_spec_eq A (d: t A) x: - get (rem d x) x = None. -Proof. - unfold get, rem; apply PositiveMap.grs; auto. -Qed. - -Lemma rem_spec_diff A (d: t A) x y: - x <> y -> get (rem d x) y = get d y. -Proof. - unfold get, rem; intros; apply PositiveMap.gro; auto. -Qed. - - -Definition empty {A}: t A := PositiveMap.empty A. - -Lemma empty_spec A x: - get (empty (A:=A)) x = None. -Proof. - unfold get, empty; apply PositiveMap.gempty; auto. -Qed. - -Import PositiveMap. - -Fixpoint eq_test {A} (d1 d2: t A): ?? bool := - match d1, d2 with - | Leaf _, Leaf _ => RET true - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - else - RET false - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ eq_test l1 l2 ;; - if b1 then - eq_test r1 r2 - else - RET false - | _, _ => RET false - end. - -Lemma eq_test_correct A d1: forall (d2: t A), - WHEN eq_test d1 d2 ~> b THEN - b=true -> forall x, get d1 x = get d2 x. -Proof. - unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl; - wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)). -Qed. -Global Opaque eq_test. - -(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *) -Fixpoint pick {A} (d: t A): ?? R.t := - match d with - | Leaf _ => FAILWITH "unexpected empty dictionary" - | Node _ (Some _) _ => RET xH - | Node (Leaf _) None r => - DO p <~ pick r;; - RET (xI p) - | Node l None _ => - DO p <~ pick l;; - RET (xO p) - end. - -(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *) -Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t := - match d1, d2 with - | Leaf _, Leaf _ => RET None - | Node l1 (Some x1) r1, Node l2 (Some x2) r2 => - DO b0 <~ phys_eq x1 x2 ;; - if b0 then - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - else - RET (Some xH) - | Node l1 None r1, Node l2 None r2 => - DO b1 <~ not_eq_witness l1 l2;; - match b1 with - | None => - DO b2 <~ not_eq_witness r1 r2;; - match b2 with - | None => RET None - | Some p => RET (Some (xI p)) - end - | Some p => RET (Some (xO p)) - end - | l, Leaf _ => DO p <~ pick l;; RET (Some p) - | Leaf _, r => DO p <~ pick r;; RET (Some p) - | _, _ => RET (Some xH) - end. - -End ImpPosDict. - diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v deleted file mode 100644 index dd9785b5..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpConfig.v +++ /dev/null @@ -1,85 +0,0 @@ -(** Impure Config for UNTRUSTED backend !!! *) - -Require Import ImpMonads. -Require Extraction. -(** Pure computations (used for extraction !) - -We keep module [Impure] opaque in order to check that Coq proof do not depend on -the implementation of [Impure]. - -*) - -Module Type ImpureView. - - Include MayReturnMonad. - -(* WARNING: THIS IS REALLY UNSAFE TO DECOMMENT THE "UnsafeImpure" module ! - - unsafe_coerce coerces an impure computation into a pure one ! - -*) - -(* START COMMENT *) - Module UnsafeImpure. - - Parameter unsafe_coerce: forall {A}, t A -> option A. - - Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x. - - Extraction Inline unsafe_coerce. - - End UnsafeImpure. -(* END COMMENT *) - - -End ImpureView. - - -Module Impure: ImpureView. - - Include IdentityMonad. - - Module UnsafeImpure. - - Definition unsafe_coerce {A} (x:t A) := Some x. - - Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x. - Proof. - unfold unsafe_coerce, mayRet; congruence. - Qed. - - End UnsafeImpure. - -End Impure. - - -(** Comment the above code and decomment this to test that coq proofs still work with an impure monad ! - -- this should fail only on extraction or if unsafe_coerce is used ! - -*) -(* -Module Impure: MayReturnMonad := PowerSetMonad. -*) - -Export Impure. - -Extraction Inline ret mk_annot. - - -(* WARNING. The following directive is unsound. - - Extraction Inline bind - -For example, it may lead to extract the following code as "true" (instead of an error raising code) - failwith "foo";;true - -*) - -Extract Inlined Constant bind => "(|>)". - - -Extract Constant t "" => "". (* This weird directive extracts [t] as "'a" instead of "'a t" *) -Extraction Inline t. - -Global Opaque t. diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v deleted file mode 100644 index 508b3f19..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpCore.v +++ /dev/null @@ -1,196 +0,0 @@ -(** Impure monad for interface with impure code - -*) - -Require Export Program. -Require Export ImpConfig. - -(* Theory: bind + embed => dbind - -Program Definition dbind {A B} (k1: t A) (k2: forall (a:A), (mayRet k1 a) -> t B) : t B - := bind (mk_annot k1) (fun a => k2 a _). - -Lemma mayRet_dbind: forall (A B:Type) k1 k2 (b:B), - mayRet (dbind k1 k2) b -> exists a:A, exists H: (mayRet k1 a), mayRet (k2 a H) b. -Proof. - intros A B k1 k2 b H; decompose [ex and] (mayRet_bind _ _ _ _ _ H). - eapply ex_intro. - eapply ex_intro. - eauto. -Qed. - -*) - -Definition wlp {A:Type} (k: t A) (P: A -> Prop): Prop - := forall a, mayRet k a -> P a. - -(* Notations *) - -(* Print Grammar constr. *) - -Module Notations. - - Bind Scope impure_scope with t. - Delimit Scope impure_scope with impure. - - Notation "?? A" := (t A) (at level 0, A at level 95): impure_scope. - - Notation "k '~~>' a" := (mayRet k a) (at level 75, no associativity): impure_scope. - - Notation "'RET' a" := (ret a) (at level 0): impure_scope. - - Notation "'DO' x '<~' k1 ';;' k2" := (bind k1 (fun x => k2)) - (at level 55, k1 at level 53, x at level 99, right associativity): impure_scope. - - Notation "k1 ';;' k2" := (bind k1 (fun _ => k2)) - (at level 55, right associativity): impure_scope. - - Notation "'WHEN' k '~>' a 'THEN' R" := (wlp k (fun a => R)) - (at level 73, R at level 100, right associativity): impure_scope. - - Notation "'ASSERT' P" := (ret (A:=P) _) (at level 0, only parsing): impure_scope. - -End Notations. - -Import Notations. -Local Open Scope impure. - -Goal ((?? list nat * ??nat -> nat) = ((?? ((list nat) * ?? nat) -> nat)))%type. -Proof. - apply refl_equal. -Qed. - - -(* wlp lemmas for tactics *) - -Lemma wlp_unfold A (k:??A)(P: A -> Prop): - (forall a, k ~~> a -> P a) - -> wlp k P. -Proof. - auto. -Qed. - -Lemma wlp_monotone A (k:?? A) (P1 P2: A -> Prop): - wlp k P1 - -> (forall a, k ~~> a -> P1 a -> P2 a) - -> wlp k P2. -Proof. - unfold wlp; eauto. -Qed. - -Lemma wlp_forall A B (k:?? A) (P: B -> A -> Prop): - (forall x, wlp k (P x)) - -> wlp k (fun a => forall x, P x a). -Proof. - unfold wlp; auto. -Qed. - -Lemma wlp_ret A (P: A -> Prop) a: - P a -> wlp (ret a) P. -Proof. - unfold wlp. - intros H b H0. - rewrite <- (mayRet_ret _ a b H0). - auto. -Qed. - -Lemma wlp_bind A B (k1:??A) (k2: A -> ??B) (P: B -> Prop): - wlp k1 (fun a => wlp (k2 a) P) -> wlp (bind k1 k2) P. -Proof. - unfold wlp. - intros H a H0. - case (mayRet_bind _ _ _ _ _ H0); clear H0. - intuition eauto. -Qed. - -Lemma wlp_ifbool A (cond: bool) (k1 k2: ?? A) (P: A -> Prop): - (cond=true -> wlp k1 P) -> (cond=false -> wlp k2 P) -> wlp (if cond then k1 else k2) P. -Proof. - destruct cond; auto. -Qed. - -Lemma wlp_letprod (A B C: Type) (p: A*B) (k: A -> B -> ??C) (P: C -> Prop): - (wlp (k (fst p) (snd p)) P) - -> (wlp (let (x,y):=p in (k x y)) P). -Proof. - destruct p; simpl; auto. -Qed. - -Lemma wlp_sum (A B C: Type) (x: A+B) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): - (forall a, x=inl a -> wlp (k1 a) P) -> - (forall b, x=inr b -> wlp (k2 b) P) -> - (wlp (match x with inl a => k1 a | inr b => k2 b end) P). -Proof. - destruct x; simpl; auto. -Qed. - -Lemma wlp_sumbool (A B:Prop) (C: Type) (x: {A}+{B}) (k1: A -> ??C) (k2: B -> ??C) (P: C -> Prop): - (forall a, x=left a -> wlp (k1 a) P) -> - (forall b, x=right b -> wlp (k2 b) P) -> - (wlp (match x with left a => k1 a | right b => k2 b end) P). -Proof. - destruct x; simpl; auto. -Qed. - -Lemma wlp_option (A B: Type) (x: option A) (k1: A -> ??B) (k2: ??B) (P: B -> Prop): - (forall a, x=Some a -> wlp (k1 a) P) -> - (x=None -> wlp k2 P) -> - (wlp (match x with Some a => k1 a | None => k2 end) P). -Proof. - destruct x; simpl; auto. -Qed. - -(* Tactics - -MAIN tactics: - - xtsimplify "base": simplification using from hints in "base" database (in particular "wlp" lemmas). - - xtstep "base": only one step of simplification. - -For good performance, it is recommanded to have several databases. - -*) - -Ltac introcomp := - let a:= fresh "exta" in - let H:= fresh "Hexta" in - intros a H. - -(* decompose the current wlp goal using "introduction" rules *) -Ltac wlp_decompose := - apply wlp_ret - || apply wlp_bind - || apply wlp_ifbool - || apply wlp_letprod - || apply wlp_sum - || apply wlp_sumbool - || apply wlp_option - . - -(* this tactic simplifies the current "wlp" goal using any hint found via tactic "hint". *) -Ltac apply_wlp_hint hint := - eapply wlp_monotone; - [ hint; fail | idtac ] ; - simpl; introcomp. - -(* one step of wlp_xsimplify -*) -Ltac wlp_step hint := - match goal with - | |- (wlp _ _) => - wlp_decompose - || apply_wlp_hint hint - || (apply wlp_unfold; introcomp) - end. - -(* main general tactic -WARNING: for the good behavior of "wlp_xsimplify", "hint" must at least perform a "eauto". - -Example of use: - wlp_xsimplify (intuition eauto with base). -*) -Ltac wlp_xsimplify hint := - repeat (intros; subst; wlp_step hint; simpl; (tauto || hint)). - -Create HintDb wlp discriminated. - -Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). diff --git a/mppa_k1c/abstractbb/Impure/ImpExtern.v b/mppa_k1c/abstractbb/Impure/ImpExtern.v deleted file mode 100644 index 8fb3cf3b..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpExtern.v +++ /dev/null @@ -1,7 +0,0 @@ -(** Exporting Extern functions -*) - -Require Export ImpPrelude. -Require Export ImpIO. -Require Export ImpLoops. -Require Export ImpHCons. diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v deleted file mode 100644 index 637116cc..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpHCons.v +++ /dev/null @@ -1,199 +0,0 @@ -Require Export ImpIO. - -Import Notations. -Local Open Scope impure. - - -Axiom string_of_hashcode: hashcode -> ?? caml_string. -Extract Constant string_of_hashcode => "string_of_int". - -Axiom hash: forall {A}, A -> ?? hashcode. -Extract Constant hash => "Hashtbl.hash". - -(**************************) -(* (Weak) Sets *) - - -Import Dict. - -Axiom make_dict: forall {A B}, (hash_params A) -> ?? Dict.t A B. -Extract Constant make_dict => "ImpHConsOracles.make_dict". - - -Module Sets. - -Definition t {A} (mod: A -> Prop) := Dict.t A {x | mod x}. - -Definition empty {A} (hp: hash_params A) {mod:A -> Prop}: ?? t mod := - make_dict hp. - -Program Fixpoint add {A} (l: list A) {mod: A -> Prop} (d: t mod): forall {H:forall x, List.In x l -> mod x}, ?? unit := - match l with - | nil => fun H => RET () - | x::l' => fun H => - d.(set)(x,x);; - add l' d - end. - -Program Definition create {A} (hp: hash_params A) (l:list A): ?? t (fun x => List.In x l) := - DO d <~ empty hp (mod:=fun x => List.In x l);; - add l (mod:=fun x => List.In x l) d (H:=_);; - RET d. -Global Opaque create. - -Definition is_present {A} (hp: hash_params A) (x:A) {mod} (d:t mod): ?? bool := - DO oy <~ (d.(get)) x;; - match oy with - | Some y => hp.(test_eq) x (`y) - | None => RET false - end. - -Local Hint Resolve test_eq_correct: wlp. - -Lemma is_present_correct A (hp: hash_params A) x mod (d:t mod): - WHEN is_present hp x d ~> b THEN b=true -> mod x. -Proof. - wlp_simplify; subst; eauto. - - apply proj2_sig. - - discriminate. -Qed. -Hint Resolve is_present_correct: wlp. -Global Opaque is_present. - -Definition msg_assert_incl: pstring := "Sets.assert_incl". - -Fixpoint assert_incl {A} (hp: hash_params A) (l: list A) {mod} (d:t mod): ?? unit := - match l with - | nil => RET () - | x::l' => - DO b <~ is_present hp x d;; - if b then - assert_incl hp l' d - else ( - hp.(log) x;; - FAILWITH msg_assert_incl - ) - end. - -Lemma assert_incl_correct A (hp: hash_params A) l mod (d:t mod): - WHEN assert_incl hp l d ~> _ THEN forall x, List.In x l -> mod x. -Proof. - induction l; wlp_simplify; subst; eauto. -Qed. -Hint Resolve assert_incl_correct: wlp. -Global Opaque assert_incl. - -Definition assert_list_incl {A} (hp: hash_params A) (l1 l2: list A): ?? unit := - (* println "";;print("dict_create ");;*) - DO d <~ create hp l2;; - (*print("assert_incl ");;*) - assert_incl hp l1 d. - -Lemma assert_list_incl_correct A (hp: hash_params A) l1 l2: - WHEN assert_list_incl hp l1 l2 ~> _ THEN List.incl l1 l2. -Proof. - wlp_simplify. -Qed. -Global Opaque assert_list_incl. -Hint Resolve assert_list_incl_correct: wlp. - -End Sets. - - - - -(********************************) -(* (Weak) HConsing *) - -Module HConsing. - -Export HConsingDefs. - -(* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *) -Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A. -Extract Constant xhCons => "ImpHConsOracles.xhCons". - -Definition hCons_eq_msg: pstring := "xhCons: hash eq differs". - -Definition hCons {A} (hp: hashP A): ?? (hashConsing A) := - DO hco <~ xhCons hp ;; - RET {| - hC := (fun x => - DO x' <~ hC hco x ;; - DO b0 <~ hash_eq hp x.(hdata) x' ;; - assert_b b0 hCons_eq_msg;; - RET x'); - next_hid := hco.(next_hid); - next_log := hco.(next_log); - export := hco.(export); - remove := hco.(remove) - |}. - - -Lemma hCons_correct A (hp: hashP A): - WHEN hCons hp ~> hco THEN - (forall x y, WHEN hp.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hp x)=(ignore_hid hp y)) -> - forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hp x.(hdata)=ignore_hid hp x'. -Proof. - wlp_simplify. -Qed. -Global Opaque hCons. -Hint Resolve hCons_correct: wlp. - - - -(* hashV: extending a given type with hash-consing *) -Record hashV {A:Type}:= { - data: A; - hid: hashcode -}. -Arguments hashV: clear implicits. - -Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashP (hashV A) := {| - hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data); - get_hid := hid; - set_hid := fun v id => {| data := v.(data); hid := id |} -|}. - -Definition liftHV (x:nat) := {| data := x; hid := unknown_hid |}. - -Definition hConsV {A} (hasheq: A -> A -> ?? bool): ?? (hashConsing (hashV A)) := - hCons (hashV_C hasheq). - -Lemma hConsV_correct A (hasheq: A -> A -> ?? bool): - WHEN hConsV hasheq ~> hco THEN - (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) -> - forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data). -Proof. - Local Hint Resolve f_equal2: core. - wlp_simplify. - exploit H; eauto. - + wlp_simplify. - + intros; congruence. -Qed. -Global Opaque hConsV. -Hint Resolve hConsV_correct: wlp. - -Definition hC_known {A} (hco:hashConsing (hashV A)) (unknownHash_msg: hashinfo (hashV A) -> ?? pstring) (x:hashinfo (hashV A)): ?? hashV A := - DO clock <~ hco.(next_hid)();; - DO x' <~ hco.(hC) x;; - DO ok <~ hash_older x'.(hid) clock;; - if ok - then RET x' - else - hco.(remove) x;; - DO msg <~ unknownHash_msg x;; - FAILWITH msg. - -Lemma hC_known_correct A (hco:hashConsing (hashV A)) msg x: - WHEN hC_known hco msg x ~> x' THEN - (forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data)) -> - x.(hdata).(data)=x'.(data). -Proof. - wlp_simplify. - unfold wlp in * |- ; eauto. -Qed. -Global Opaque hC_known. -Hint Resolve hC_known_correct: wlp. - -End HConsing. diff --git a/mppa_k1c/abstractbb/Impure/ImpIO.v b/mppa_k1c/abstractbb/Impure/ImpIO.v deleted file mode 100644 index 6c02c395..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpIO.v +++ /dev/null @@ -1,159 +0,0 @@ -(** Extension of Coq language with some IO and exception-handling operators. - -TODO: integration with http://coq.io/ ? - -*) - -Require Export ImpPrelude. - -Import Notations. -Local Open Scope impure. - -(** Printing functions *) - -Axiom print: pstring -> ?? unit. -Extract Constant print => "ImpIOOracles.print". - -Axiom println: pstring -> ?? unit. -Extract Constant println => "ImpIOOracles.println". - -Axiom read_line: unit -> ?? pstring. -Extract Constant read_line => "ImpIOOracles.read_line". - -Require Import ZArith. -Axiom string_of_Z: Z -> ?? pstring. -Extract Constant string_of_Z => "ImpIOOracles.string_of_Z". - -(** timer *) - -Axiom timer: forall {A B}, (A -> ?? B)*A -> ?? B. -Extract Constant timer => "ImpIOOracles.timer". - -(** Exception Handling *) - -Axiom exit_observer: Type. -Extract Constant exit_observer => "((unit -> unit) ref)". - -Axiom new_exit_observer: (unit -> ??unit) -> ??exit_observer. -Extract Constant new_exit_observer => "ImpIOOracles.new_exit_observer". - -Axiom set_exit_observer: exit_observer * (unit -> ??unit) -> ??unit. -Extract Constant set_exit_observer => "ImpIOOracles.set_exit_observer". - -Axiom exn: Type. -Extract Inlined Constant exn => "exn". - -Axiom raise: forall {A}, exn -> ?? A. -Extract Constant raise => "raise". - -Axiom exn2string: exn -> ?? pstring. -Extract Constant exn2string => "ImpIOOracles.exn2string". - -Axiom fail: forall {A}, pstring -> ?? A. -Extract Constant fail => "ImpIOOracles.fail". - -Axiom try_with_fail: forall {A}, (unit -> ?? A) * (pstring -> exn -> ??A) -> ??A. -Extract Constant try_with_fail => "ImpIOOracles.try_with_fail". - -Axiom try_with_any: forall {A}, (unit -> ?? A) * (exn -> ??A) -> ??A. -Extract Constant try_with_any => "ImpIOOracles.try_with_any". - -Notation "'RAISE' e" := (DO r <~ raise (A:=False) e ;; RET (match r with end)) (at level 0): impure_scope. -Notation "'FAILWITH' msg" := (DO r <~ fail (A:=False) msg ;; RET (match r with end)) (at level 0): impure_scope. - -Definition _FAILWITH {A:Type} msg: ?? A := FAILWITH msg. - -Example _FAILWITH_correct A msg (P: A -> Prop): - WHEN _FAILWITH msg ~> r THEN P r. -Proof. - wlp_simplify. -Qed. - -Notation "'TRY' k1 'WITH_FAIL' s ',' e '=>' k2" := (try_with_fail (fun _ => k1, fun s e => k2)) - (at level 55, k1 at level 53, right associativity): impure_scope. - -Notation "'TRY' k1 'WITH_ANY' e '=>' k2" := (try_with_any (fun _ => k1, fun e => k2)) - (at level 55, k1 at level 53, right associativity): impure_scope. - - -Program Definition assert_b (b: bool) (msg: pstring): ?? b=true := - match b with - | true => RET _ - | false => FAILWITH msg - end. - -Lemma assert_wlp_true msg b: WHEN assert_b b msg ~> _ THEN b=true. -Proof. - wlp_simplify. -Qed. - -Lemma assert_false_wlp msg (P: Prop): WHEN assert_b false msg ~> _ THEN P. -Proof. - simpl; wlp_simplify. -Qed. - -Program Definition try_catch_fail_ensure {A} (k1: unit -> ?? A) (k2: pstring -> exn -> ??A) (P: A -> Prop | wlp (k1 tt) P /\ (forall s e, wlp (k2 s e) P)): ?? { r | P r } - := TRY - DO r <~ mk_annot (k1 tt);; - RET (exist P r _) - WITH_FAIL s, e => - DO r <~ mk_annot (k2 s e);; - RET (exist P r _). -Obligation 2. - unfold wlp in * |- *; eauto. -Qed. - -Notation "'TRY' k1 'CATCH_FAIL' s ',' e '=>' k2 'ENSURE' P" := (try_catch_fail_ensure (fun _ => k1) (fun s e => k2) (exist _ P _)) - (at level 55, k1 at level 53, right associativity): impure_scope. - -Definition is_try_post {A} (P: A -> Prop) k1 k2 : Prop := - wlp (k1 ()) P /\ forall (e:exn), wlp (k2 e) P. - -Program Definition try_catch_ensure {A} k1 k2 (P:A->Prop|is_try_post P k1 k2): ?? { r | P r } - := TRY - DO r <~ mk_annot (k1 ());; - RET (exist P r _) - WITH_ANY e => - DO r <~ mk_annot (k2 e);; - RET (exist P r _). -Obligation 1. - unfold is_try_post, wlp in * |- *; intuition eauto. -Qed. -Obligation 2. - unfold is_try_post, wlp in * |- *; intuition eauto. -Qed. - -Notation "'TRY' k1 'CATCH' e '=>' k2 'ENSURE' P" := (try_catch_ensure (fun _ => k1) (fun e => k2) (exist _ P _)) - (at level 55, k1 at level 53, right associativity): impure_scope. - - -Program Example tryex {A} (x y:A) := - TRY (RET x) - CATCH _ => (RET y) - ENSURE (fun r => r = x \/ r = y). -Obligation 1. - split; wlp_simplify. -Qed. - -Program Example tryex_test {A} (x y:A): - WHEN tryex x y ~> r THEN `r <> x -> `r = y. -Proof. - wlp_simplify. destruct exta as [r [X|X]]; intuition. -Qed. - - -Program Example try_branch1 {A} (x:A): ?? { r | r = x} := - TRY (RET x) - CATCH e => (FAILWITH "!") - ENSURE _. -Obligation 1. - split; wlp_simplify. -Qed. - -Program Example try_branch2 {A} (x:A): ?? { r | r = x} := - TRY (FAILWITH "!") - CATCH e => (RET x) - ENSURE _. -Obligation 1. - split; wlp_simplify. -Qed. diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v deleted file mode 100644 index 33376c19..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpLoops.v +++ /dev/null @@ -1,123 +0,0 @@ -(** Extension of Coq language with generic loops. *) - -Require Export ImpIO. - -Import Notations. -Local Open Scope impure. - - -(** While-loop iterations *) - -Axiom loop: forall {A B}, A * (A -> ?? (A+B)) -> ?? B. -Extract Constant loop => "ImpLoopOracles.loop". - - -Section While_Loop. - -(** Local Definition of "while-loop-invariant" *) -Let wli {S} cond body (I: S -> Prop) := forall s, I s -> cond s = true -> WHEN (body s) ~> s' THEN I s'. - -Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | (I s0 -> I s) /\ cond s = false} - := loop (A:={s | I s0 -> I s}) - (s0, - fun s => - match (cond s) with - | true => - DO s' <~ mk_annot (body s) ;; - RET (inl (A:={s | I s0 -> I s }) s') - | false => - RET (inr (B:={s | (I s0 -> I s) /\ cond s = false}) s) - end). -Obligation 2. - unfold wli, wlp in * |-; eauto. -Qed. -Extraction Inline while. - -End While_Loop. - - -Section Loop_Until_None. -(** useful to demonstrate a UNSAT property *) - -(** Local Definition of "loop-until-None-invariant" *) -Let luni {S} (body: S -> ?? (option S)) (I: S -> Prop) := forall s, I s -> WHEN (body s) ~> s' THEN match s' with Some s1 => I s1 | None => False end. - -Program Definition loop_until_None {S} body (I: S -> Prop | luni body I) s0: ?? ~(I s0) - := loop (A:={s | I s0 -> I s}) - (s0, - fun s => - DO s' <~ mk_annot (body s) ;; - match s' with - | Some s1 => RET (inl (A:={s | I s0 -> I s }) s1) - | None => RET (inr (B:=~(I s0)) _) - end). -Obligation 2. - refine (H2 s _ _ H0). auto. -Qed. -Obligation 3. - intros X; refine (H1 s _ _ H). auto. -Qed. -Extraction Inline loop_until_None. - -End Loop_Until_None. - - -(*********************************************) -(* A generic fixpoint from an equality test *) - -Record answ {A B: Type} {R: A -> B -> Prop} := { - input: A ; - output: B ; - correct: R input output -}. -Arguments answ {A B}. - -Definition msg: pstring := "wapply fails". - -Definition beq_correct {A} (beq: A -> A -> ?? bool) := - forall x y, WHEN beq x y ~> b THEN b=true -> x=y. - -Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ?? answ R) (x:A): ?? B := - DO a <~ k x;; - DO b <~ beq x (input a) ;; - assert_b b msg;; - RET (output a). - -Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool) (k: A -> ?? answ R) x: - beq_correct beq - -> WHEN wapply beq k x ~> y THEN R x y. -Proof. - unfold beq_correct; wlp_simplify. - destruct exta; simpl; auto. -Qed. -Local Hint Resolve wapply_correct: wlp. -Global Opaque wapply. - -Axiom xrec_set_option: recMode -> ?? unit. -Extract Constant xrec_set_option => "ImpLoopOracles.xrec_set_option". - -(* TODO: generalizaton to get beq (and a Hash function ?) in parameters ? *) -Axiom xrec: forall {A B}, ((A -> ?? B) -> A -> ?? B) -> ?? (A -> ?? B). -Extract Constant xrec => "ImpLoopOracles.xrec". - -Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop) := - forall f x, WHEN recF f x ~> z THEN (forall x', WHEN f x' ~> y THEN R x' y) -> R x z. - - -Program Definition rec {A B} beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): ?? (A -> ?? B) := - DO f <~ xrec (B:=answ R) (fun f x => - DO y <~ mk_annot (recF (wapply beq f) x) ;; - RET {| input := x; output := `y |});; - RET (wapply beq f). -Obligation 1. - eapply H1; eauto. clear H H1. - wlp_simplify. -Qed. - -Lemma rec_correct A B beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): - WHEN rec beq recF R H1 H2 ~> f THEN forall x, WHEN f x ~> y THEN R x y. -Proof. - wlp_simplify. -Qed. -Hint Resolve rec_correct: wlp. -Global Opaque rec. diff --git a/mppa_k1c/abstractbb/Impure/ImpMonads.v b/mppa_k1c/abstractbb/Impure/ImpMonads.v deleted file mode 100644 index f01a2755..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpMonads.v +++ /dev/null @@ -1,148 +0,0 @@ -(** Impure monad for interface with impure code -*) - - -Require Import Program. - - -Module Type MayReturnMonad. - - Axiom t: Type -> Type. - - Axiom mayRet: forall {A:Type}, t A -> A -> Prop. - - Axiom ret: forall {A}, A -> t A. - - Axiom bind: forall {A B}, (t A) -> (A -> t B) -> t B. - - Axiom mk_annot: forall {A} (k: t A), t { a: A | mayRet k a }. - - Axiom mayRet_ret: forall A (a b:A), - mayRet (ret a) b -> a=b. - - Axiom mayRet_bind: forall A B k1 k2 (b:B), - mayRet (bind k1 k2) b -> exists a:A, mayRet k1 a /\ mayRet (k2 a) b. - -End MayReturnMonad. - - - -(** Model of impure computation as predicate *) -Module PowerSetMonad<: MayReturnMonad. - - Definition t (A:Type) := A -> Prop. - - Definition mayRet {A:Type} (k: t A) a: Prop := k a. - - Definition ret {A:Type} (a:A) := eq a. - - Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := - fun b => exists a, k1 a /\ k2 a b. - - Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := fun _ => True. - - Lemma mayRet_ret A (a b:A): mayRet (ret a) b -> a=b. - Proof. - unfold mayRet, ret. firstorder. - Qed. - - Lemma mayRet_bind A B k1 k2 (b:B): - mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. - Proof. - unfold mayRet, bind. - firstorder. - Qed. - -End PowerSetMonad. - - -(** The identity interpretation *) -Module IdentityMonad<: MayReturnMonad. - - Definition t (A:Type) := A. - - (* may-return semantics of computations *) - Definition mayRet {A:Type} (a b:A): Prop := a=b. - - Definition ret {A:Type} (a:A) := a. - - Definition bind {A B:Type} (k1: A) (k2: A -> B) := k2 k1. - - Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } - := exist _ k (eq_refl k) . - - Lemma mayRet_ret (A:Type) (a b:A): mayRet (ret a) b -> a=b. - Proof. - intuition. - Qed. - - Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): - mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. - Proof. - firstorder. - Qed. - -End IdentityMonad. - - -(** Model of impure computation as state-transformers *) -Module StateMonad<: MayReturnMonad. - - Parameter St: Type. (* A global state *) - - Definition t (A:Type) := St -> A * St. - - Definition mayRet {A:Type} (k: t A) a: Prop := - exists s, fst (k s)=a. - - Definition ret {A:Type} (a:A) := fun (s:St) => (a,s). - - Definition bind {A B:Type} (k1: t A) (k2: A -> t B) := - fun s0 => let r := k1 s0 in k2 (fst r) (snd r). - - Program Definition mk_annot {A} (k: t A) : t { a | mayRet k a } := - fun s0 => let r := k s0 in (exist _ (fst r) _, snd r). - Obligation 1. - unfold mayRet; eauto. - Qed. - - Lemma mayRet_ret {A:Type} (a b:A): mayRet (ret a) b -> a=b. - Proof. - unfold mayRet, ret. firstorder. - Qed. - - Lemma mayRet_bind {A B:Type} k1 k2 (b:B): - mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. - Proof. - unfold mayRet, bind. firstorder eauto. - Qed. - -End StateMonad. - -(** The deferred interpretation *) -Module DeferredMonad<: MayReturnMonad. - - Definition t (A:Type) := unit -> A. - - (* may-return semantics of computations *) - Definition mayRet {A:Type} (a: t A) (b:A): Prop := a tt=b. - - Definition ret {A:Type} (a:A) : t A := fun _ => a. - - Definition bind {A B:Type} (k1: t A) (k2: A -> t B) : t B := fun _ => k2 (k1 tt) tt. - - Definition mk_annot {A} (k: t A) : t { a: A | mayRet k a } - := fun _ => exist _ (k tt) (eq_refl (k tt)). - - Lemma mayRet_ret (A:Type) (a b: A): mayRet (ret a) b -> a=b. - Proof. - intuition. - Qed. - - Lemma mayRet_bind (A B:Type) (k1:t A) k2 (b:B): - mayRet (bind k1 k2) b -> exists (a:A), mayRet k1 a /\ mayRet (k2 a) b. - Proof. - firstorder. - Qed. - -End DeferredMonad. diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v deleted file mode 100644 index de4c7973..00000000 --- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v +++ /dev/null @@ -1,206 +0,0 @@ -Require Export String. -Require Export List. -Require Extraction. -Require Import Ascii. -Require Import BinNums. -Require Export ImpCore. -Require Export PArith. - - -Import Notations. -Local Open Scope impure. - -(** Impure lazy andb of booleans *) -Definition iandb (k1 k2: ??bool): ?? bool := - DO r1 <~ k1 ;; - if r1 then k2 else RET false. - -Extraction Inline iandb. (* Juste pour l'efficacité à l'extraction ! *) - -(** Strings for pretty-printing *) - -Axiom caml_string: Type. -Extract Constant caml_string => "string". - -(* New line *) -Definition nl: string := String (ascii_of_pos 10%positive) EmptyString. - -Inductive pstring: Type := - | Str: string -> pstring - | CamlStr: caml_string -> pstring - | Concat: pstring -> pstring -> pstring. - -Coercion Str: string >-> pstring. -Bind Scope string_scope with pstring. - -Notation "x +; y" := (Concat x y) - (at level 65, left associativity): string_scope. - -(** Coq references *) - -Record cref {A} := { - set: A -> ?? unit; - get: unit -> ?? A -}. -Arguments cref: clear implicits. - -Axiom make_cref: forall {A}, A -> ?? cref A. -Extract Constant make_cref => "(fun x -> let r = ref x in { set = (fun y -> r:=y); get = (fun () -> !r) })". - - -(** Data-structure for a logger *) - -Record logger {A:Type} := { - log_insert: A -> ?? unit; - log_info: unit -> ?? pstring; -}. -Arguments logger: clear implicits. - -Axiom count_logger: unit -> ?? logger unit. -Extract Constant count_logger => "(fun () -> let count = ref 0 in { log_insert = (fun () -> count := !count + 1); log_info = (fun () -> (CamlStr (string_of_int !count))) })". - - -(** Axioms of Physical equality *) - -Axiom phys_eq: forall {A}, A -> A -> ?? bool. - -Axiom phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. - - -(* We only check here that above axioms are not trivially inconsistent... - (but this does not prove the correctness of the extraction directive below). - *) -Module PhysEqModel. - -Definition phys_eq {A} (x y: A) := ret false. - -Lemma phys_eq_correct: forall A (x y:A), WHEN phys_eq x y ~> b THEN b=true -> x=y. -Proof. - wlp_simplify. discriminate. -Qed. - -End PhysEqModel. - -Extract Inlined Constant phys_eq => "(==)". -Hint Resolve phys_eq_correct: wlp. - - -Axiom struct_eq: forall {A}, A -> A -> ?? bool. -Axiom struct_eq_correct: forall A (x y:A), WHEN struct_eq x y ~> b THEN if b then x=y else x<>y. -Extract Inlined Constant struct_eq => "(=)". -Hint Resolve struct_eq_correct: wlp. - - -(** Data-structure for generic hash-consing *) - -Axiom hashcode: Type. -Extract Constant hashcode => "int". - -(* NB: hashConsing is assumed to generate hash-code in ascending order. - This gives a way to check that a hash-consed value is older than an other one. -*) -Axiom hash_older: hashcode -> hashcode -> ?? bool. -Extract Inlined Constant hash_older => "(<)". - -Module Dict. - -Record hash_params {A:Type} := { - test_eq: A -> A -> ??bool; - test_eq_correct: forall x y, WHEN test_eq x y ~> r THEN r=true -> x=y; - hashing: A -> ??hashcode; - log: A -> ??unit (* for debugging only *) -}. -Arguments hash_params: clear implicits. - - -Record t {A B:Type} := { - set: A * B -> ?? unit; - get: A -> ?? option B -}. -Arguments t: clear implicits. - -End Dict. - -Module HConsingDefs. - -Record hashinfo {A: Type} := { - hdata: A; - hcodes: list hashcode; -}. -Arguments hashinfo: clear implicits. - -(* for inductive types with intrinsic hash-consing *) -Record hashP {A:Type}:= { - hash_eq: A -> A -> ?? bool; - get_hid: A -> hashcode; - set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *) -}. -Arguments hashP: clear implicits. - -Axiom unknown_hid: hashcode. -Extract Constant unknown_hid => "-1". - -Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid. - -Record hashExport {A:Type}:= { - get_info: hashcode -> ?? hashinfo A; - iterall: ((list pstring) -> hashcode -> hashinfo A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *) -}. -Arguments hashExport: clear implicits. - -Record hashConsing {A:Type}:= { - hC: hashinfo A -> ?? A; - (**** below: debugging or internal functions ****) - next_hid: unit -> ?? hashcode; (* should be strictly less old than ignore_hid *) - remove: hashinfo A -> ??unit; (* SHOULD NOT BE USED ! *) - next_log: pstring -> ?? unit; (* insert a log info (for the next introduced element) -- regiven by [iterall export] below *) - export: unit -> ?? hashExport A ; -}. -Arguments hashConsing: clear implicits. - -End HConsingDefs. - -(** recMode: this is mainly for Tests ! *) -Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec. - - -(* This a copy-paste from definitions in CompCert/Lib/CoqLib.v *) -Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q. -Proof. auto. Qed. - -Ltac exploit x := - refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _ _) _) - || refine (modusponens _ _ (x _ _ _) _) - || refine (modusponens _ _ (x _ _) _) - || refine (modusponens _ _ (x _) _). diff --git a/mppa_k1c/abstractbb/Impure/LICENSE b/mppa_k1c/abstractbb/Impure/LICENSE deleted file mode 100644 index 65c5ca88..00000000 --- a/mppa_k1c/abstractbb/Impure/LICENSE +++ /dev/null @@ -1,165 +0,0 @@ - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. diff --git a/mppa_k1c/abstractbb/Impure/README.md b/mppa_k1c/abstractbb/Impure/README.md deleted file mode 100644 index 2b19d14a..00000000 --- a/mppa_k1c/abstractbb/Impure/README.md +++ /dev/null @@ -1,31 +0,0 @@ -# `Impure`: importing OCaml functions as non-deterministic ones. - -The principle of this library is to encode the type `A -> B` of an -OCaml function as a type `A -> ?? B` in Coq, where `?? B` is the type -of an axiomatized monad that can be interpreted as `B -> Prop`. In -other word, this encoding abstracts an OCaml function as a function -returning a postcondition on its possible results (ie a relation between its -parameter and its result). Side-effects are simply ignored. And -reasoning on such a function is only possible in partial correctness. - -See further explanations and examples on [ImpureDemo](https://github.com/boulme/ImpureDemo). - -## Credits - -[Sylvain Boulmé](mailto:Sylvain.Boulme@univ-grenoble-alpes.fr). - -## Code Overview - -- [ImpMonads](ImpMonads.v) axioms of "impure computations" and some Coq models of these axioms. - -- [ImpConfig](ImpConfig.v) declares the `Impure` monad and defines its extraction. - -- [ImpCore](ImpCore.v) defines notations for the `Impure` monad and a `wlp_simplify` tactic (to reason about `Impure` functions in a Hoare-logic style). - -- [ImpPrelude](ImpPrelude.v) declares the data types exchanged with `Impure` oracles. - -- [ImpIO](ImpIO.v), [ImpLoops](ImpLoops.v), [ImpHCons](ImpHCons.v) declare `Impure` oracles and define operators from these oracles. - [ImpExtern](ImpExtern.v) exports all these impure operators. - -- [ocaml/](ocaml/) subdirectory containing the OCaml implementations of `Impure` oracles. - diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml deleted file mode 100644 index 2b66899b..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml +++ /dev/null @@ -1,66 +0,0 @@ -open ImpPrelude -open HConsingDefs - -let make_dict (type key) (p: key Dict.hash_params) = - let module MyHashedType = struct - type t = key - let equal = p.Dict.test_eq - let hash = p.Dict.hashing - end in - let module MyHashtbl = Hashtbl.Make(MyHashedType) in - let dict = MyHashtbl.create 1000 in - { - Dict.set = (fun (k,d) -> MyHashtbl.replace dict k d); - Dict.get = (fun k -> MyHashtbl.find_opt dict k) - } - - -exception Stop;; - -let xhCons (type a) (hp:a hashP) = - (* We use a hash-table, but a hash-set would be sufficient ! *) - (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *) - (* Ideally, a parameter would allow to select between the weak or full version *) - let module MyHashedType = struct - type t = a hashinfo - let equal x y = hp.hash_eq x.hdata y.hdata - let hash x = Hashtbl.hash x.hcodes - end in - let module MyHashtbl = Hashtbl.Make(MyHashedType) in - let pick t = - let res = ref None in - try - MyHashtbl.iter (fun k d -> res:=Some (k,d); raise Stop) t; - None - with - | Stop -> !res - in - let t = MyHashtbl.create 1000 in - let logs = ref [] in - { - hC = (fun (k:a hashinfo) -> - match MyHashtbl.find_opt t k with - | Some d -> d - | None -> (*print_string "+";*) - let d = hp.set_hid k.hdata (MyHashtbl.length t) in - MyHashtbl.add t {k with hdata = d } d; d); - next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs)); - next_hid = (fun () -> MyHashtbl.length t); - remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x); - export = fun () -> - match pick t with - | None -> { get_info = (fun _ -> raise Not_found); iterall = (fun _ -> ()) } - | Some (k,_) -> - (* the state is fully copied at export ! *) - let logs = ref (List.rev_append (!logs) []) in - let rec step_log i = - match !logs with - | (j, info)::l' when i>=j -> logs:=l'; info::(step_log i) - | _ -> [] - in let a = Array.make (MyHashtbl.length t) k in - MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t; - { - get_info = (fun i -> a.(i)); - iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a) - } - } diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli deleted file mode 100644 index 5075d176..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli +++ /dev/null @@ -1,5 +0,0 @@ -open ImpPrelude -open HConsingDefs - -val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t -val xhCons: 'a hashP -> 'a hashConsing diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml deleted file mode 100644 index 9e63c12d..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml +++ /dev/null @@ -1,142 +0,0 @@ -(* Warning - -These oracles assumes the following extraction directives: - "Require Import ExtrOcamlString." - -*) - -open ImpPrelude -(* -open BinNums -open Datatypes -*) - -(* two auxiliary functions, for efficient mapping of "int" to "BinNums.positive" *) -exception Overflow - -let aux_add: ('a, 'b) Hashtbl.t -> 'b Queue.t -> 'a -> 'b -> unit - = fun t q i p -> - if i < 1 then (* protection against wrap around *) - raise Overflow; - Queue.add p q; - Hashtbl.add t i p - -let memo_int2pos: int -> int -> BinNums.positive - = fun n -> - (* init of the Hashtbl *) - let n = max n 1 in - let t = Hashtbl.create n in - let q = Queue.create () in - aux_add t q 1 BinNums.Coq_xH ; - for i = 1 to (n-1)/2 do - let last = Queue.take q in - let ni = 2*i in - aux_add t q ni (BinNums.Coq_xO last); - aux_add t q (ni+1) (BinNums.Coq_xI last) - done; - if n mod 2 = 0 then ( - let last = Queue.take q in - Hashtbl.add t n (BinNums.Coq_xO last) - ); - (* memoized translation of i *) - let rec find i = - try - (* Printf.printf "-> %d\n" i; *) - Hashtbl.find t i - with Not_found -> - (* Printf.printf "<- %d\n" i; *) - if i <= 0 then - invalid_arg "non-positive integer" - else - let p = find (i/2) in - let pi = if i mod 2 = 0 then BinNums.Coq_xO p else BinNums.Coq_xI p in - Hashtbl.add t i pi; - pi - in find;; - -let new_exit_observer: (unit -> unit) -> (unit -> unit) ref - = fun f -> - let o = ref f in - at_exit (fun () -> !o()); - o;; - -let set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit - = fun (r, f) -> r := f - -let rec print: pstring -> unit - = fun ps -> - match ps with - | Str l -> List.iter print_char l - | CamlStr s -> print_string s - | Concat(ps1,ps2) -> (print ps1; print ps2);; - -let println: pstring -> unit - = fun l -> print l; print_newline() - -let read_line () = - CamlStr (Stdlib.read_line());; - -exception ImpureFail of pstring;; - -let exn2string: exn -> pstring - = fun e -> CamlStr (Printexc.to_string e) - -let fail: pstring -> 'a - = fun s -> raise (ImpureFail s);; - -let try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a - = fun (k1, k2) -> - try - k1() - with - | (ImpureFail s) as e -> k2 s e - -let try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a - = fun (k1, k2) -> - try - k1() - with - | e -> k2 e - -(** MISC **) - -let rec posTr: BinNums.positive -> int -= function - | BinNums.Coq_xH -> 1 - | BinNums.Coq_xO p -> (posTr p)*2 - | BinNums.Coq_xI p -> (posTr p)*2+1;; - -let zTr: BinNums.coq_Z -> int -= function - | BinNums.Z0 -> 0 - | BinNums.Zpos p -> posTr p - | BinNums.Zneg p -> - (posTr p) - -let ten = BinNums.Zpos (BinNums.Coq_xO (BinNums.Coq_xI (BinNums.Coq_xO BinNums.Coq_xH))) - -let rec string_of_pos (p:BinNums.positive) (acc: pstring): pstring -= let (q,r) = BinInt.Z.pos_div_eucl p ten in - let acc0 = Concat (CamlStr (string_of_int (zTr r)), acc) in - match q with - | BinNums.Z0 -> acc0 - | BinNums.Zpos p0 -> string_of_pos p0 acc0 - | _ -> assert false - -(* -let string_of_Z_debug: BinNums.coq_Z -> pstring -= fun p -> CamlStr (string_of_int (zTr p)) -*) - -let string_of_Z: BinNums.coq_Z -> pstring -= function - | BinNums.Z0 -> CamlStr "0" - | BinNums.Zpos p -> string_of_pos p (CamlStr "") - | BinNums.Zneg p -> Concat (CamlStr "-", string_of_pos p (CamlStr "")) - -let timer ((f:'a -> 'b), (x:'a)) : 'b = - Gc.compact(); - let itime = (Unix.times()).Unix.tms_utime in - let r = f x in - let rt = (Unix.times()).Unix.tms_utime -. itime in - Printf.printf "time = %f\n" rt; - r diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli deleted file mode 100644 index 6064286a..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.mli +++ /dev/null @@ -1,33 +0,0 @@ -open ImpPrelude - - -(* -Memoized version of translation from int -> BinNums.positive. -The first arg is an indicative bound on the max int translated: -it pre-computes all positives lower or equal to this bound. -*) -val memo_int2pos: int -> int -> BinNums.positive - -val read_line: unit -> pstring - -val print: pstring -> unit - -val println: pstring -> unit - -val string_of_Z: BinNums.coq_Z -> pstring - -val timer : (('a -> 'b ) * 'a) -> 'b - -val new_exit_observer: (unit -> unit) -> (unit -> unit) ref - -val set_exit_observer: (unit -> unit) ref * (unit -> unit) -> unit - -val exn2string: exn -> pstring - -val fail: pstring -> 'a - -exception ImpureFail of pstring;; - -val try_with_fail: (unit -> 'a) * (pstring -> exn -> 'a) -> 'a - -val try_with_any: (unit -> 'a) * (exn -> 'a) -> 'a diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml deleted file mode 100644 index cb7625e5..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.ml +++ /dev/null @@ -1,78 +0,0 @@ -open ImpPrelude -open Datatypes - -(** GENERIC ITERATIVE LOOP **) - -(* a simple version of loop *) -let simple_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b - = fun (a0, f) -> - let rec iter: 'a -> 'b - = fun a -> - match f a with - | Coq_inl a' -> iter a' - | Coq_inr b -> b - in - iter a0;; - -(* loop from while *) -let while_loop: ('a * ('a -> ('a, 'b) sum)) -> 'b - = fun (a0, f) -> - let s = ref (f a0) in - while (match !s with Coq_inl _ -> true | _ -> false) do - match !s with - | Coq_inl a -> s:=f a - | _ -> assert false - done; - match !s with - | Coq_inr b -> b - | _ -> assert false;; - -let loop = simple_loop - - -(** GENERIC FIXPOINTS **) - -let std_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = - let rec f x = recf f x in - f - -let memo_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = - let memo = Hashtbl.create 10 in - let rec f x = - try - Hashtbl.find memo x - with - Not_found -> - let r = recf f x in - Hashtbl.replace memo x r; - r - in f - -let bare_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = - let fix = ref (fun x -> failwith "init") in - fix := (fun x -> recf !fix x); - !fix;; - -let buggy_rec (recf: ('a -> 'b ) -> 'a -> 'b): 'a -> 'b = - let memo = ref None in - let rec f x = - match !memo with - | Some y -> y - | None -> - let r = recf f x in - memo := Some r; - r - in f - -let xrec_mode = ref MemoRec - -let xrec_set_option : recMode -> unit -= fun m -> xrec_mode := m - -let xrec : (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) - = fun recf -> - match !xrec_mode with - | StdRec -> std_rec recf - | MemoRec -> memo_rec recf - | BareRec -> bare_rec recf - | BuggyRec -> buggy_rec recf diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli deleted file mode 100644 index 194696a1..00000000 --- a/mppa_k1c/abstractbb/Impure/ocaml/ImpLoopOracles.mli +++ /dev/null @@ -1,8 +0,0 @@ -open ImpPrelude -open Datatypes - -val loop: ('a * ('a -> ('a, 'b) sum)) -> 'b - -val xrec_set_option: recMode -> unit - -val xrec: (('a -> 'b ) -> 'a -> 'b ) -> ('a -> 'b ) diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v deleted file mode 100644 index feebeee5..00000000 --- a/mppa_k1c/abstractbb/Parallelizability.v +++ /dev/null @@ -1,793 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** Parallel Semantics of Abstract Basic Blocks and parallelizability test. -*) - -Require Setoid. (* in order to rewrite <-> *) -Require Export AbstractBasicBlocksDef. - -Require Import List. -Import ListNotations. -Local Open Scope list_scope. - -Require Import Sorting.Permutation. -Require Import Bool. -Local Open Scope lazy_bool_scope. - - -Module ParallelSemantics (L: SeqLanguage). - -Export L. -Local Open Scope list. - -Section PARALLEL. -Variable ge: genv. - -(* parallel run of a inst *) -Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem := - match i with - | nil => Some m - | (x, e)::i' => - match exp_eval ge e tmp old with - | Some v' => inst_prun i' (assign m x v') (assign tmp x v') old - | None => None - end - end. - -(* [inst_prun] is generalization of [inst_run] *) -Lemma inst_run_prun i: forall m old, - inst_run ge i m old = inst_prun i m m old. -Proof. - induction i as [|[y e] i']; simpl; auto. - intros m old; destruct (exp_eval ge e m old); simpl; auto. -Qed. - - -(* parallel run of a bblock -- with in-order writes *) -Fixpoint prun_iw (p: bblock) m old: option mem := - match p with - | nil => Some m - | i::p' => - match inst_prun i m old old with - | Some m1 => prun_iw p' m1 old - | None => None - end - end. - -(* non-deterministic parallel run, due to arbitrary writes order *) -Definition prun (p: bblock) m (om: option mem) := exists p', res_eq om (prun_iw p' m m) /\ Permutation p p'. - - -(* a few lemma on equality *) - -Lemma inst_prun_equiv i old: forall m1 m2 tmp, - (forall x, m1 x = m2 x) -> - res_eq (inst_prun i m1 tmp old) (inst_prun i m2 tmp old). -Proof. - induction i as [|[x e] i']; simpl; eauto. - intros m1 m2 tmp H; destruct (exp_eval ge e tmp old); simpl; auto. - eapply IHi'; unfold assign. intros; destruct (R.eq_dec x x0); auto. -Qed. - -Lemma prun_iw_equiv p: forall m1 m2 old, - (forall x, m1 x = m2 x) -> - res_eq (prun_iw p m1 old) (prun_iw p m2 old). -Proof. - induction p as [|i p']; simpl; eauto. - - intros m1 m2 old H. - generalize (inst_prun_equiv i old m1 m2 old H); - destruct (inst_prun i m1 old old); simpl. - + intros (m3 & H3 & H4); rewrite H3; simpl; eauto. - + intros H1; rewrite H1; simpl; auto. -Qed. - - -Lemma prun_iw_app p1: forall m1 old p2, - prun_iw (p1++p2) m1 old = - match prun_iw p1 m1 old with - | Some m2 => prun_iw p2 m2 old - | None => None - end. -Proof. - induction p1; simpl; try congruence. - intros; destruct (inst_prun _ _ _); simpl; auto. -Qed. - -Lemma prun_iw_app_None p1: forall m1 old p2, - prun_iw p1 m1 old = None -> - prun_iw (p1++p2) m1 old = None. -Proof. - intros m1 old p2 H; rewrite prun_iw_app. rewrite H; auto. -Qed. - -Lemma prun_iw_app_Some p1: forall m1 old m2 p2, - prun_iw p1 m1 old = Some m2 -> - prun_iw (p1++p2) m1 old = prun_iw p2 m2 old. -Proof. - intros m1 old m2 p2 H; rewrite prun_iw_app. rewrite H; auto. -Qed. - -End PARALLEL. -End ParallelSemantics. - - - -Fixpoint notIn {A} (x: A) (l:list A): Prop := - match l with - | nil => True - | a::l' => x <> a /\ notIn x l' - end. - -Lemma notIn_iff A (x:A) l: (~List.In x l) <-> notIn x l. -Proof. - induction l; simpl; intuition. -Qed. - -Lemma notIn_app A (x:A) l1: forall l2, notIn x (l1++l2) <-> (notIn x l1 /\ notIn x l2). -Proof. - induction l1; simpl. - - intuition. - - intros; rewrite IHl1. intuition. -Qed. - - -Lemma In_Permutation A (l1 l2: list A): Permutation l1 l2 -> forall x, In x l1 -> In x l2. -Proof. - induction 1; simpl; intuition. -Qed. - -Lemma Permutation_incl A (l1 l2: list A): Permutation l1 l2 -> incl l1 l2. -Proof. - unfold incl; intros; eapply In_Permutation; eauto. -Qed. - -Lemma notIn_incl A (l1 l2: list A) x: incl l1 l2 -> notIn x l2 -> notIn x l1. -Proof. - unfold incl; rewrite <- ! notIn_iff; intuition. -Qed. - - -Definition disjoint {A: Type} (l l':list A) : Prop := forall x, In x l -> notIn x l'. - -Lemma disjoint_sym_imp A (l1 l2: list A): disjoint l1 l2 -> disjoint l2 l1. -Proof. - unfold disjoint. intros H x H1. generalize (H x). rewrite <- !notIn_iff. intuition. -Qed. - -Lemma disjoint_sym A (l1 l2: list A): disjoint l1 l2 <-> disjoint l2 l1. -Proof. - constructor 1; apply disjoint_sym_imp; auto. -Qed. - - -Lemma disjoint_cons_l A (x:A) (l1 l2: list A): disjoint (x::l1) l2 <-> (notIn x l2) /\ (disjoint l1 l2). -Proof. - unfold disjoint. simpl; intuition subst; auto. -Qed. - -Lemma disjoint_cons_r A (x:A) (l1 l2: list A): disjoint l1 (x::l2) <-> (notIn x l1) /\ (disjoint l1 l2). -Proof. - rewrite disjoint_sym, disjoint_cons_l, disjoint_sym; intuition. -Qed. - -Lemma disjoint_app_r A (l l1 l2: list A): disjoint l (l1++l2) <-> (disjoint l l1 /\ disjoint l l2). -Proof. - unfold disjoint. intuition. - - generalize (H x H0). rewrite notIn_app; intuition. - - generalize (H x H0). rewrite notIn_app; intuition. - - rewrite notIn_app; intuition. -Qed. - -Lemma disjoint_app_l A (l l1 l2: list A): disjoint (l1++l2) l <-> (disjoint l1 l /\ disjoint l2 l). -Proof. - rewrite disjoint_sym, disjoint_app_r; intuition; rewrite disjoint_sym; auto. -Qed. - -Lemma disjoint_incl_r A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l l2 -> disjoint l l1. -Proof. - unfold disjoint. intros; eapply notIn_incl; eauto. -Qed. - -Lemma disjoint_incl_l A (l1 l2: list A): incl l1 l2 -> forall l, disjoint l2 l -> disjoint l1 l. -Proof. - intros; rewrite disjoint_sym. eapply disjoint_incl_r; eauto. rewrite disjoint_sym; auto. -Qed. - - -Module ParallelizablityChecking (L: SeqLanguage). - -Include ParallelSemantics L. - -Section PARALLELI. -Variable ge: genv. - -(** * Preliminary notions on frames *) - -Lemma notIn_dec (x: R.t) l : { notIn x l } + { In x l }. -Proof. - destruct (In_dec R.eq_dec x l). constructor 2; auto. - constructor 1; rewrite <- notIn_iff. auto. -Qed. - -Fixpoint frame_assign m1 (f: list R.t) m2 := - match f with - | nil => m1 - | x::f' => frame_assign (assign m1 x (m2 x)) f' m2 - end. - -Lemma frame_assign_def f: forall m1 m2 x, - frame_assign m1 f m2 x = if notIn_dec x f then m1 x else m2 x. -Proof. - induction f as [|y f] ; simpl; auto. - - intros; destruct (notIn_dec x []); simpl in *; tauto. - - intros; rewrite IHf; destruct (notIn_dec x (y::f)); simpl in *. - + destruct (notIn_dec x f); simpl in *; intuition. - rewrite assign_diff; auto. - rewrite <- notIn_iff in *; intuition. - + destruct (notIn_dec x f); simpl in *; intuition subst. - rewrite assign_eq; auto. - rewrite <- notIn_iff in *; intuition. -Qed. - -Lemma frame_assign_In m1 f m2 x: - In x f -> frame_assign m1 f m2 x = m2 x. -Proof. - intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. - rewrite <- notIn_iff in *; intuition. -Qed. - -Lemma frame_assign_notIn m1 f m2 x: - notIn x f -> frame_assign m1 f m2 x = m1 x. -Proof. - intros; rewrite frame_assign_def; destruct (notIn_dec x f); auto. - rewrite <- notIn_iff in *; intuition. -Qed. - -Definition frame_eq (frame: R.t -> Prop) (om1 om2: option mem): Prop := - match om1 with - | Some m1 => exists m2, om2 = Some m2 /\ forall x, (frame x) -> m1 x = m2 x - | None => om2 = None - end. - -Lemma frame_eq_list_split f1 (f2: R.t -> Prop) om1 om2: - frame_eq (fun x => In x f1) om1 om2 -> - (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> f2 x -> notIn x f1 -> m1 x = m2 x) -> - frame_eq f2 om1 om2. -Proof. - unfold frame_eq; destruct om1 as [ m1 | ]; simpl; auto. - intros (m2 & H0 & H1); subst. - intros H. - eexists; intuition eauto. - destruct (notIn_dec x f1); auto. -Qed. - -(* -Lemma frame_eq_res_eq f om1 om2: - frame_eq (fun x => In x f) om1 om2 -> - (forall m1 m2 x, om1 = Some m1 -> om2 = Some m2 -> notIn x f -> m1 x = m2 x) -> - res_eq om1 om2. -Proof. - intros H H0; lapply (frame_eq_list_split f (fun _ => True) om1 om2 H); eauto. - clear H H0; unfold frame_eq, res_eq. destruct om1; simpl; firstorder. -Qed. -*) - -(** * Writing frames *) - -Fixpoint inst_wframe(i:inst): list R.t := - match i with - | nil => nil - | a::i' => (fst a)::(inst_wframe i') - end. - -Lemma inst_wframe_correct i m' old: forall m tmp, - inst_prun ge i m tmp old = Some m' -> - forall x, notIn x (inst_wframe i) -> m' x = m x. -Proof. - induction i as [|[y e] i']; simpl. - - intros m tmp H x H0; inversion_clear H; auto. - - intros m tmp H x (H1 & H2); destruct (exp_eval ge e tmp old); simpl; try congruence. - cutrewrite (m x = assign m y v x); eauto. - rewrite assign_diff; auto. -Qed. - -Lemma inst_prun_fequiv i old: forall m1 m2 tmp, - frame_eq (fun x => In x (inst_wframe i)) (inst_prun ge i m1 tmp old) (inst_prun ge i m2 tmp old). -Proof. - induction i as [|[y e] i']; simpl. - - intros m1 m2 tmp; eexists; intuition eauto. - - intros m1 m2 tmp. destruct (exp_eval ge e tmp old); simpl; auto. - eapply frame_eq_list_split; eauto. clear IHi'. - intros m1' m2' x H1 H2. - lapply (inst_wframe_correct i' m1' old (assign m1 y v) (assign tmp y v)); eauto. - lapply (inst_wframe_correct i' m2' old (assign m2 y v) (assign tmp y v)); eauto. - intros Xm2 Xm1 H H0. destruct H. - + subst. rewrite Xm1, Xm2; auto. rewrite !assign_eq. auto. - + rewrite <- notIn_iff in H0; tauto. -Qed. - -Lemma inst_prun_None i m1 m2 tmp old: - inst_prun ge i m1 tmp old = None -> - inst_prun ge i m2 tmp old = None. -Proof. - intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). - rewrite H; simpl; auto. -Qed. - -Lemma inst_prun_Some i m1 m2 tmp old m1': - inst_prun ge i m1 tmp old = Some m1' -> - res_eq (Some (frame_assign m2 (inst_wframe i) m1')) (inst_prun ge i m2 tmp old). -Proof. - intros H; generalize (inst_prun_fequiv i old m1 m2 tmp). - rewrite H; simpl. - intros (m2' & H1 & H2). - eexists; intuition eauto. - rewrite frame_assign_def. - lapply (inst_wframe_correct i m2' old m2 tmp); eauto. - destruct (notIn_dec x (inst_wframe i)); auto. - intros X; rewrite X; auto. -Qed. - -Fixpoint bblock_wframe(p:bblock): list R.t := - match p with - | nil => nil - | i::p' => (inst_wframe i)++(bblock_wframe p') - end. - -Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core. - -Lemma bblock_wframe_Permutation p p': - Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p'). -Proof. - induction 1 as [|i p p'|i1 i2 p|p1 p2 p3]; simpl; auto. - - rewrite! app_assoc; auto. - - eapply Permutation_trans; eauto. -Qed. - -(* -Lemma bblock_wframe_correct p m' old: forall m, - prun_iw p m old = Some m' -> - forall x, notIn x (bblock_wframe p) -> m' x = m x. -Proof. - induction p as [|i p']; simpl. - - intros m H; inversion_clear H; auto. - - intros m H x; rewrite notIn_app; intros (H1 & H2). - remember (inst_prun i m old old) as om. - destruct om as [m1|]; simpl. - + eapply eq_trans. - eapply IHp'; eauto. - eapply inst_wframe_correct; eauto. - + inversion H. -Qed. - -Lemma prun_iw_fequiv p old: forall m1 m2, - frame_eq (fun x => In x (bblock_wframe p)) (prun_iw p m1 old) (prun_iw p m2 old). -Proof. - induction p as [|i p']; simpl. - - intros m1 m2; eexists; intuition eauto. - - intros m1 m2; generalize (inst_prun_fequiv i old m1 m2 old). - remember (inst_prun i m1 old old) as om. - destruct om as [m1'|]; simpl. - + intros (m2' & H1 & H2). rewrite H1; simpl. - eapply frame_eq_list_split; eauto. clear IHp'. - intros m1'' m2'' x H3 H4. rewrite in_app_iff. - intros X X2. assert (X1: In x (inst_wframe i)). { destruct X; auto. rewrite <- notIn_iff in X2; tauto. } - clear X. - lapply (bblock_wframe_correct p' m1'' old m1'); eauto. - lapply (bblock_wframe_correct p' m2'' old m2'); eauto. - intros Xm2' Xm1'. - rewrite Xm1', Xm2'; auto. - + intro H; rewrite H; simpl; auto. -Qed. - -Lemma prun_iw_equiv p m1 m2 old: - (forall x, notIn x (bblock_wframe p) -> m1 x = m2 x) -> - res_eq (prun_iw p m1 old) (prun_iw p m2 old). -Proof. - intros; eapply frame_eq_res_eq. - eapply prun_iw_fequiv. - intros m1' m2' x H1 H2 H0.Require - lapply (bblock_wframe_correct p m1' old m1); eauto. - lapply (bblock_wframe_correct p m2' old m2); eauto. - intros X2 X1; rewrite X1, X2; auto. -Qed. -*) - -(** * Checking that parallel semantics is deterministic *) - -Fixpoint is_det (p: bblock): Prop := - match p with - | nil => True - | i::p' => - disjoint (inst_wframe i) (bblock_wframe p') (* no WRITE-AFTER-WRITE *) - /\ is_det p' - end. - -Lemma is_det_Permutation p p': - Permutation p p' -> is_det p -> is_det p'. -Proof. - induction 1; simpl; auto. - - intros; intuition. eapply disjoint_incl_r. 2: eauto. - eapply Permutation_incl. eapply Permutation_sym. - eapply bblock_wframe_Permutation; auto. - - rewrite! disjoint_app_r in * |- *. intuition. - rewrite disjoint_sym; auto. -Qed. - -Theorem is_det_correct p p': - Permutation p p' -> - is_det p -> - forall m old, res_eq (prun_iw ge p m old) (prun_iw ge p' m old). -Proof. - induction 1 as [ | i p p' | i1 i2 p | p1 p2 p3 ]; simpl; eauto. - - intros [H0 H1] m old. - remember (inst_prun ge i m old old) as om0. - destruct om0 as [ m0 | ]; simpl; auto. - - rewrite disjoint_app_r. - intros ([Z1 Z2] & Z3 & Z4) m old. - remember (inst_prun ge i2 m old old) as om2. - destruct om2 as [ m2 | ]; simpl; auto. - + remember (inst_prun ge i1 m old old) as om1. - destruct om1 as [ m1 | ]; simpl; auto. - * lapply (inst_prun_Some i2 m m1 old old m2); simpl; auto. - lapply (inst_prun_Some i1 m m2 old old m1); simpl; auto. - intros (m1' & Hm1' & Xm1') (m2' & Hm2' & Xm2'). - rewrite Hm1', Hm2'; simpl. - eapply prun_iw_equiv. - intros x; rewrite <- Xm1', <- Xm2'. clear Xm2' Xm1' Hm1' Hm2' m1' m2'. - rewrite frame_assign_def. - rewrite disjoint_sym in Z1; unfold disjoint in Z1. - destruct (notIn_dec x (inst_wframe i1)) as [ X1 | X1 ]. - { rewrite frame_assign_def; destruct (notIn_dec x (inst_wframe i2)) as [ X2 | X2 ]; auto. - erewrite (inst_wframe_correct i2 m2 old m old); eauto. - erewrite (inst_wframe_correct i1 m1 old m old); eauto. - } - rewrite frame_assign_notIn; auto. - * erewrite inst_prun_None; eauto. simpl; auto. - + remember (inst_prun ge i1 m old old) as om1. - destruct om1 as [ m1 | ]; simpl; auto. - erewrite inst_prun_None; eauto. - - intros; eapply res_eq_trans. - eapply IHPermutation1; eauto. - eapply IHPermutation2; eauto. - eapply is_det_Permutation; eauto. -Qed. - -(** * Standard Frames *) - -Fixpoint exp_frame (e: exp): list R.t := - match e with - | PReg x => x::nil - | Op o le => list_exp_frame le - | Old e => exp_frame e - end -with list_exp_frame (le: list_exp): list R.t := - match le with - | Enil => nil - | Econs e le' => exp_frame e ++ list_exp_frame le' - | LOld le => list_exp_frame le - end. - -Lemma exp_frame_correct e old1 old2: - (forall x, In x (exp_frame e) -> old1 x = old2 x) -> - forall m1 m2, (forall x, In x (exp_frame e) -> m1 x = m2 x) -> - (exp_eval ge e m1 old1)=(exp_eval ge e m2 old2). -Proof. - induction e using exp_mut with (P0:=fun l => (forall x, In x (list_exp_frame l) -> old1 x = old2 x) -> forall m1 m2, (forall x, In x (list_exp_frame l) -> m1 x = m2 x) -> - (list_exp_eval ge l m1 old1)=(list_exp_eval ge l m2 old2)); simpl; auto. - - intros H1 m1 m2 H2; rewrite H2; auto. - - intros H1 m1 m2 H2; erewrite IHe; eauto. - - intros H1 m1 m2 H2; erewrite IHe, IHe0; eauto; - intros; (eapply H1 || eapply H2); rewrite in_app_iff; auto. -Qed. - -Fixpoint inst_frame (i: inst): list R.t := - match i with - | nil => nil - | a::i' => (fst a)::(exp_frame (snd a) ++ inst_frame i') - end. - -Lemma inst_wframe_frame i x: In x (inst_wframe i) -> In x (inst_frame i). -Proof. - induction i as [ | [y e] i']; simpl; intuition. -Qed. - - -Lemma inst_frame_correct i wframe old1 old2: forall m tmp1 tmp2, - (disjoint (inst_frame i) wframe) -> - (forall x, notIn x wframe -> old1 x = old2 x) -> - (forall x, notIn x wframe -> tmp1 x = tmp2 x) -> - inst_prun ge i m tmp1 old1 = inst_prun ge i m tmp2 old2. -Proof. - induction i as [|[x e] i']; simpl; auto. - intros m tmp1 tmp2; rewrite disjoint_cons_l, disjoint_app_l. - intros (H1 & H2 & H3) H6 H7. - cutrewrite (exp_eval ge e tmp1 old1 = exp_eval ge e tmp2 old2). - - destruct (exp_eval ge e tmp2 old2); auto. - eapply IHi'; eauto. - simpl; intros x0 H0; unfold assign. destruct (R.eq_dec x x0); simpl; auto. - - unfold disjoint in H2; apply exp_frame_correct. - intros;apply H6; auto. - intros;apply H7; auto. -Qed. - -(** * Parallelizability *) - -Fixpoint pararec (p: bblock) (wframe: list R.t): Prop := - match p with - | nil => True - | i::p' => - disjoint (inst_frame i) wframe (* no USE-AFTER-WRITE *) - /\ pararec p' ((inst_wframe i) ++ wframe) - end. - -Lemma pararec_disjoint (p: bblock): forall wframe, pararec p wframe -> disjoint (bblock_wframe p) wframe. -Proof. - induction p as [|i p']; simpl. - - unfold disjoint; simpl; intuition. - - intros wframe [H0 H1]; rewrite disjoint_app_l. - generalize (IHp' _ H1). - rewrite disjoint_app_r. intuition. - eapply disjoint_incl_l. 2: eapply H0. - unfold incl. eapply inst_wframe_frame; eauto. -Qed. - -Lemma pararec_det p: forall wframe, pararec p wframe -> is_det p. -Proof. - induction p as [|i p']; simpl; auto. - intros wframe [H0 H1]. generalize (pararec_disjoint _ _ H1). rewrite disjoint_app_r. - intuition. - - apply disjoint_sym; auto. - - eapply IHp'. eauto. -Qed. - -Lemma pararec_correct p old: forall wframe m, - pararec p wframe -> - (forall x, notIn x wframe -> m x = old x) -> - run ge p m = prun_iw ge p m old. -Proof. - elim p; clear p; simpl; auto. - intros i p' X wframe m [H H0] H1. - erewrite inst_run_prun, inst_frame_correct; eauto. - remember (inst_prun ge i m old old) as om0. - destruct om0 as [m0 | ]; try congruence. - eapply X; eauto. - intro x; rewrite notIn_app. intros [H3 H4]. - rewrite <- H1; auto. - eapply inst_wframe_correct; eauto. -Qed. - -Definition parallelizable (p: bblock) := pararec p nil. - -Theorem parallelizable_correct p m om': - parallelizable p -> (prun ge p m om' <-> res_eq om' (run ge p m)). -Proof. - intros H. constructor 1. - - intros (p' & H0 & H1). eapply res_eq_trans; eauto. - erewrite pararec_correct; eauto. - eapply res_eq_sym. - eapply is_det_correct; eauto. - eapply pararec_det; eauto. - - intros; unfold prun. - eexists. constructor 1. 2: apply Permutation_refl. - erewrite pararec_correct in H0; eauto. -Qed. - -End PARALLELI. - -End ParallelizablityChecking. - - -Module Type PseudoRegSet. - -Declare Module R: PseudoRegisters. - -(** We assume a datatype [t] refining (list R.t) - -This data-refinement is given by an abstract "invariant" match_frame below, -preserved by the following operations. - -*) - -Parameter t: Type. -Parameter match_frame: t -> (list R.t) -> Prop. - -Parameter empty: t. -Parameter empty_match_frame: match_frame empty nil. - -Parameter add: R.t -> t -> t. -Parameter add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). - -Parameter union: t -> t -> t. -Parameter union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). - -Parameter is_disjoint: t -> t -> bool. -Parameter is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. - -End PseudoRegSet. - - -Lemma lazy_andb_bool_true (b1 b2: bool): b1 &&& b2 = true <-> b1 = true /\ b2 = true. -Proof. - destruct b1, b2; intuition. -Qed. - - - - -Module ParallelChecks (L: SeqLanguage) (S:PseudoRegSet with Module R:=L.LP.R). - -Include ParallelizablityChecking L. - -Section PARALLEL2. -Variable ge: genv. - -Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core. - -(** Now, refinement of each operation toward parallelizable *) - -Fixpoint inst_wsframe(i:inst): S.t := - match i with - | nil => S.empty - | a::i' => S.add (fst a) (inst_wsframe i') - end. - -Lemma inst_wsframe_correct i: S.match_frame (inst_wsframe i) (inst_wframe i). -Proof. - induction i; simpl; auto. -Qed. - -Fixpoint exp_sframe (e: exp): S.t := - match e with - | PReg x => S.add x S.empty - | Op o le => list_exp_sframe le - | Old e => exp_sframe e - end -with list_exp_sframe (le: list_exp): S.t := - match le with - | Enil => S.empty - | Econs e le' => S.union (exp_sframe e) (list_exp_sframe le') - | LOld le => list_exp_sframe le - end. - -Lemma exp_sframe_correct e: S.match_frame (exp_sframe e) (exp_frame e). -Proof. - induction e using exp_mut with (P0:=fun l => S.match_frame (list_exp_sframe l) (list_exp_frame l)); simpl; auto. -Qed. - -Fixpoint inst_sframe (i: inst): S.t := - match i with - | nil => S.empty - | a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i')) - end. - -Local Hint Resolve exp_sframe_correct: core. - -Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i). -Proof. - induction i as [|[y e] i']; simpl; auto. -Qed. - -Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core. - -Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool := - match p with - | nil => true - | i::p' => - S.is_disjoint (inst_sframe i) wsframe (* no USE-AFTER-WRITE *) - &&& is_pararec p' (S.union (inst_wsframe i) wsframe) - end. - -Lemma is_pararec_correct (p: bblock): forall s l, S.match_frame s l -> (is_pararec p s)=true -> (pararec p l). -Proof. - induction p; simpl; auto. - intros s l H1 H2; rewrite lazy_andb_bool_true in H2. destruct H2 as [H2 H3]. - constructor 1; eauto. -Qed. - -Definition is_parallelizable (p: bblock) := is_pararec p S.empty. - -Lemma is_para_correct_aux p: is_parallelizable p = true -> parallelizable p. -Proof. - unfold is_parallelizable, parallelizable; intros; eapply is_pararec_correct; eauto. -Qed. - -Theorem is_parallelizable_correct p: - is_parallelizable p = true -> forall m om', (prun ge p m om' <-> res_eq om' (run ge p m)). -Proof. - intros; apply parallelizable_correct. - apply is_para_correct_aux. auto. -Qed. - -End PARALLEL2. -End ParallelChecks. - - - - -Require Import PArith. -Require Import MSets.MSetPositive. - -Module PosPseudoRegSet <: PseudoRegSet with Module R:=Pos. - -Module R:=Pos. - -(** We assume a datatype [t] refining (list R.t) - -This data-refinement is given by an abstract "invariant" match_frame below, -preserved by the following operations. - -*) - -Definition t:=PositiveSet.t. - -Definition match_frame (s:t) (l:list R.t): Prop - := forall x, PositiveSet.In x s <-> In x l. - -Definition empty:=PositiveSet.empty. - -Lemma empty_match_frame: match_frame empty nil. -Proof. - unfold match_frame, empty, PositiveSet.In; simpl; intuition. -Qed. - -Definition add: R.t -> t -> t := PositiveSet.add. - -Lemma add_match_frame: forall s x l, match_frame s l -> match_frame (add x s) (x::l). -Proof. - unfold match_frame, add; simpl. - intros s x l H y. rewrite PositiveSet.add_spec, H. - intuition. -Qed. - -Definition union: t -> t -> t := PositiveSet.union. -Lemma union_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> match_frame (union s1 s2) (l1++l2). -Proof. - unfold match_frame, union. - intros s1 s2 l1 l2 H1 H2 x. rewrite PositiveSet.union_spec, H1, H2. - intuition. -Qed. - -Fixpoint is_disjoint (s s': PositiveSet.t) : bool := - match s with - | PositiveSet.Leaf => true - | PositiveSet.Node l o r => - match s' with - | PositiveSet.Leaf => true - | PositiveSet.Node l' o' r' => - if (o &&& o') then false else (is_disjoint l l' &&& is_disjoint r r') - end - end. - -Lemma is_disjoint_spec_true s: forall s', is_disjoint s s' = true -> forall x, PositiveSet.In x s -> PositiveSet.In x s' -> False. -Proof. - unfold PositiveSet.In; induction s as [ |l IHl o r IHr]; simpl; try discriminate. - destruct s' as [|l' o' r']; simpl; try discriminate. - intros X. - assert (H: ~(o = true /\ o'=true) /\ is_disjoint l l' = true /\ is_disjoint r r'=true). - { destruct o, o', (is_disjoint l l'), (is_disjoint r r'); simpl in X; intuition. } - clear X; destruct H as (H & H1 & H2). - destruct x as [i|i|]; simpl; eauto. -Qed. - -Lemma is_disjoint_match_frame: forall s1 s2 l1 l2, match_frame s1 l1 -> match_frame s2 l2 -> (is_disjoint s1 s2)=true -> disjoint l1 l2. -Proof. - unfold match_frame, disjoint. - intros s1 s2 l1 l2 H1 H2 H3 x. - rewrite <- notIn_iff, <- H1, <- H2. - intros H4 H5; eapply is_disjoint_spec_true; eauto. -Qed. - -End PosPseudoRegSet. diff --git a/mppa_k1c/abstractbb/README.md b/mppa_k1c/abstractbb/README.md deleted file mode 100644 index 69e5defc..00000000 --- a/mppa_k1c/abstractbb/README.md +++ /dev/null @@ -1,12 +0,0 @@ -# Coq sources of AbstractBasicBlocks - -- [AbstractBasicBlocksDef](AbstractBasicBlocksDef.v): syntax and sequential semantics of abstract basic blocks (on which we define our analyzes). -This syntax and semantics is parametrized in order to adapt the language for different concrete basic block languages. - -- [Parallelizability](Parallelizability.v): define the parallel semantics and the 'is_parallelizable' function which tests whether the sequential run of a given abstract basic block is the same than a parallel run. - -- [DepTreeTheory](DepTreeTheory.v): defines a theory of dependency trees, such that two basic blocks with the same dependency tree have the same sequential semantics. In practice, permuting the instructions inside a basic block while perserving the dependencies of assignments should not change the dependency tree. The idea is to verify list schedulings, following ideas of [Formal verification of translation validators proposed by Tristan and Leroy](https://hal.inria.fr/inria-00289540/). - -- [ImpDep](ImpDep.v): adds a hash-consing mechanism to trees of [DepTreeTheory](DepTreeTheory.v), and thus provides an efficient "equality" test (a true answer ensures that the two basic blocks in input have the same sequential semantics) in order to check the correctness of list schedulings. - -- [DepExample](DepExample.v) defines a toy language (syntax and semantics); [DepExampleEqTest](DepExampleEqTest.v) defines a compiler of the toy language into abstract basic blocks and derives an equality test for the toy language; [DepExampleParallelTest](DepExampleParallelTest.v) derives a parallelizability test from the previous compiler; [DepExampleDemo](DepExampleDemo.v) is a test-suite for both tetsts. diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v deleted file mode 100644 index 61f8f2ec..00000000 --- a/mppa_k1c/abstractbb/SeqSimuTheory.v +++ /dev/null @@ -1,396 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* *) -(* Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** A theory for checking/proving simulation by symbolic execution. - -*) - - -Require Coq.Logic.FunctionalExtensionality. (* not really necessary -- see lemma at the end *) -Require Setoid. (* in order to rewrite <-> *) -Require Export AbstractBasicBlocksDef. -Require Import List. -Require Import ImpPrelude. -Import HConsingDefs. - - -Module SimuTheory (L: SeqLanguage). - -Export L. -Export LP. - -Inductive term := - | Input (x:R.t) - | App (o: op) (l: list_term) -with list_term := - | LTnil - | LTcons (t:term) (l:list_term) - . - -Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value := - match t with - | Input x => Some (m x) - | App o l => - match list_term_eval ge l m with - | Some v => op_eval ge o v - | _ => None - end - end -with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) := - match l with - | LTnil => Some nil - | LTcons t l' => - match term_eval ge t m, list_term_eval ge l' m with - | Some v, Some lv => Some (v::lv) - | _, _ => None - end - end. - -(* the symbolic memory: - - pre: pre-condition expressing that the computation has not yet abort on a None. - - post: the post-condition for each pseudo-register -*) -Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}. - -(** initial symbolic memory *) -Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}. - -Fixpoint exp_term (e: exp) (d old: smem) : term := - match e with - | PReg x => d x - | Op o le => App o (list_exp_term le d old) - | Old e => exp_term e old old - end -with list_exp_term (le: list_exp) (d old: smem) : list_term := - match le with - | Enil => LTnil - | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old) - | LOld le => list_exp_term le old old - end. - - -(** assignment of the symbolic memory *) -Definition smem_set (d:smem) x (t:term) := - {| pre:=(fun ge m => (term_eval ge (d x) m) <> None /\ (d.(pre) ge m)); - post:=fun y => if R.eq_dec x y then t else d y |}. - -Section SIMU_THEORY. - -Variable ge: genv. - -Lemma set_spec_eq d x t m: - term_eval ge (smem_set d x t x) m = term_eval ge t m. -Proof. - unfold smem_set; simpl; case (R.eq_dec x x); try congruence. -Qed. - -Lemma set_spec_diff d x y t m: - x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m. -Proof. - unfold smem_set; simpl; case (R.eq_dec x y); try congruence. -Qed. - -Fixpoint inst_smem (i: inst) (d old: smem): smem := - match i with - | nil => d - | (x, e)::i' => - let t:=exp_term e d old in - inst_smem i' (smem_set d x t) old - end. - -Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem := - match p with - | nil => d - | i::p' => - let d':=inst_smem i d d in - bblock_smem_rec p' d' - end. - -Definition bblock_smem: bblock -> smem - := fun p => bblock_smem_rec p smem_empty. - -Lemma inst_smem_pre_monotonic i old: forall d m, - (pre (inst_smem i d old) ge m) -> (pre d ge m). -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d a H; generalize (IHi _ _ H); clear H IHi. - unfold smem_set; simpl; intuition. -Qed. - -Lemma bblock_smem_pre_monotonic p: forall d m, - (pre (bblock_smem_rec p d) ge m) -> (pre d ge m). -Proof. - induction p as [|i p' IHp']; simpl; eauto. - intros d a H; eapply inst_smem_pre_monotonic; eauto. -Qed. - -Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core. - -Lemma term_eval_exp e (od:smem) m0 old: - (forall x, term_eval ge (od x) m0 = Some (old x)) -> - forall (d:smem) m1, - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old. -Proof. - intro H. - induction e using exp_mut with - (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old); - simpl; auto. - - intros; erewrite IHe; eauto. - - intros. erewrite IHe, IHe0; eauto. -Qed. - -Lemma inst_smem_abort i m0 x old: forall (d:smem), - pre (inst_smem i d old) ge m0 -> - term_eval ge (d x) m0 = None -> - term_eval ge (inst_smem i d old x) m0 = None. -Proof. - induction i as [|[y e] i IHi]; simpl; auto. - intros d VALID H; erewrite IHi; eauto. clear IHi. - unfold smem_set; simpl; destruct (R.eq_dec y x); auto. - subst; - generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID. - unfold smem_set; simpl. intuition congruence. -Qed. - -Lemma block_smem_rec_abort p m0 x: forall d, - pre (bblock_smem_rec p d) ge m0 -> - term_eval ge (d x) m0 = None -> - term_eval ge (bblock_smem_rec p d x) m0 = None. -Proof. - induction p; simpl; auto. - intros d VALID H; erewrite IHp; eauto. clear IHp. - eapply inst_smem_abort; eauto. -Qed. - -Lemma inst_smem_Some_correct1 i m0 old (od:smem): - (forall x, term_eval ge (od x) m0 = Some (old x)) -> - forall (m1 m2: mem) (d: smem), - inst_run ge i m1 old = Some m2 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x). -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence. - refine (IHi _ _ _ _ _ _); eauto. - clear x0; intros x0. - unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. - subst; erewrite term_eval_exp; eauto. -Qed. - -Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem), - run ge p m1 = Some m2 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x). -Proof. - Local Hint Resolve inst_smem_Some_correct1: core. - induction p as [ | i p]; simpl; intros m1 m2 d H. - - inversion_clear H; eauto. - - intros H0 x0. - destruct (inst_run ge i m1 m1) eqn: Heqov. - + refine (IHp _ _ _ _ _ _); eauto. - + inversion H. -Qed. - -Lemma bblock_smem_Some_correct1 p m0 m1: - run ge p m0 = Some m1 - -> forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x). -Proof. - intros; eapply bblocks_smem_rec_Some_correct1; eauto. -Qed. - -Lemma inst_smem_None_correct i m0 old (od: smem): - (forall x, term_eval ge (od x) m0 = Some (old x)) -> - forall m1 d, pre (inst_smem i d od) ge m0 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - inst_run ge i m1 old = None -> exists x, term_eval ge (inst_smem i d od x) m0 = None. -Proof. - intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d. - - discriminate. - - intros VALID H0. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _); eauto. - intros x0; unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto. - subst; erewrite term_eval_exp; eauto. - + intuition. - constructor 1 with (x:=x); simpl. - apply inst_smem_abort; auto. - rewrite set_spec_eq. - erewrite term_eval_exp; eauto. -Qed. - -Lemma inst_smem_Some_correct2 i m0 old (od: smem): - (forall x, term_eval ge (od x) m0 = Some (old x)) -> - forall (m1 m2: mem) d, - pre (inst_smem i d od) ge m0 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - (forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x)) -> - res_eq (Some m2) (inst_run ge i m1 old). -Proof. - intro X. - induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (exp_eval ge e m1 old) eqn: Heqov. - + refine (IHi _ _ _ _ _ _); eauto. - intros x0; unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. - subst; erewrite term_eval_exp; eauto. - + generalize (H x). - rewrite inst_smem_abort; discriminate || auto. - rewrite set_spec_eq. - erewrite term_eval_exp; eauto. -Qed. - -Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d, - pre (bblock_smem_rec p d) ge m0 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - (forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x)) -> - res_eq (Some m2) (run ge p m1). -Proof. - induction p as [|i p]; simpl; intros m1 m2 d VALID H0. - - intros H; eapply ex_intro; intuition eauto. - generalize (H0 x); rewrite H. - congruence. - - intros H. - destruct (inst_run ge i m1 m1) eqn: Heqom. - + refine (IHp _ _ _ _ _ _); eauto. - + assert (X: exists x, term_eval ge (inst_smem i d d x) m0 = None). - { eapply inst_smem_None_correct; eauto. } - destruct X as [x H1]. - generalize (H x). - erewrite block_smem_rec_abort; eauto. - congruence. -Qed. - -Lemma bblock_smem_Some_correct2 p m0 m1: - pre (bblock_smem p) ge m0 -> - (forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x)) - -> res_eq (Some m1) (run ge p m0). -Proof. - intros; eapply bblocks_smem_rec_Some_correct2; eauto. -Qed. - -Lemma inst_valid i m0 old (od:smem): - (forall x, term_eval ge (od x) m0 = Some (old x)) -> - forall (m1 m2: mem) (d: smem), - pre d ge m0 -> - inst_run ge i m1 old = Some m2 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - pre (inst_smem i d od) ge m0. -Proof. - induction i as [|[x e] i IHi]; simpl; auto. - intros Hold m1 m2 d VALID0 H Hm1. - destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence. - eapply IHi; eauto. - + unfold smem_set in * |- *; simpl. - rewrite Hm1; intuition congruence. - + intros x0. unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto. - subst; erewrite term_eval_exp; eauto. -Qed. - - -Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem), - pre d ge m0 -> - run ge p m1 = Some m2 -> - (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> - pre (bblock_smem_rec p d) ge m0. -Proof. - Local Hint Resolve inst_valid: core. - induction p as [ | i p]; simpl; intros m1 d H; auto. - intros H0 H1. - destruct (inst_run ge i m1 m1) eqn: Heqov; eauto. - congruence. -Qed. - -Lemma bblock_smem_valid p m0 m1: - run ge p m0 = Some m1 -> - pre (bblock_smem p) ge m0. -Proof. - intros; eapply block_smem_rec_valid; eauto. - unfold smem_empty; simpl. auto. -Qed. - -Definition smem_valid ge d m := pre d ge m /\ forall x, term_eval ge (d x) m <> None. - -Definition smem_simu (d1 d2: smem): Prop := - (forall m, smem_valid ge d1 m -> smem_valid ge d2 m) - /\ (forall m0 x, smem_valid ge d1 m0 -> - term_eval ge (d1 x) m0 = term_eval ge (d2 x) m0). - - -Theorem bblock_smem_simu p1 p2: - smem_simu (bblock_smem p1) (bblock_smem p2) -> - bblock_simu ge p1 p2. -Proof. - Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core. - intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-. - destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence. - assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto. - eapply bblock_smem_Some_correct2; eauto. - + destruct (INCL m); intuition eauto. - congruence. - + intro x; erewrite <- EQUIV; intuition eauto. - congruence. -Qed. - -Lemma smem_valid_set_decompose_1 d t x m: - smem_valid ge (smem_set d x t) m -> smem_valid ge d m. -Proof. - unfold smem_valid; intros ((PRE1 & PRE2) & VALID); split. - + intuition. - + intros x0 H. case (R.eq_dec x x0). - * intuition congruence. - * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto. -Qed. - -Lemma smem_valid_set_decompose_2 d t x m: - smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None. -Proof. - unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H. - generalize (VALID x); rewrite set_spec_eq. - tauto. -Qed. - -Lemma smem_valid_set_proof d x t m: - smem_valid ge d m -> term_eval ge t m <> None -> smem_valid ge (smem_set d x t) m. -Proof. - unfold smem_valid; intros (PRE & VALID) PREt. split. - + split; auto. - + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto. -Qed. - - -End SIMU_THEORY. - -(** REMARKS: more abstract formulation of the proof... - but relying on functional_extensionality. -*) -Definition smem_correct ge (d: smem) (m: mem) (om: option mem): Prop:= - forall m', om=Some m' <-> (d.(pre) ge m /\ forall x, term_eval ge (d x) m = Some (m' x)). - -Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m). -Proof. - unfold smem_correct; simpl; intros m'; split. - + intros; split. - * eapply bblock_smem_valid; eauto. - * eapply bblock_smem_Some_correct1; eauto. - + intros (H1 & H2). - destruct (bblock_smem_Some_correct2 ge p m m') as (m2 & X & Y); eauto. - rewrite X. f_equal. - apply FunctionalExtensionality.functional_extensionality; auto. -Qed. - -End SimuTheory. diff --git a/mppa_k1c/bitmasks.py b/mppa_k1c/bitmasks.py deleted file mode 100755 index 9f6987d6..00000000 --- a/mppa_k1c/bitmasks.py +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env python3 -def bitmask(to, fr): - bit_to = 1< " Configuration.model = ""64"" ". -Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *) - -Extract Constant Peephole.print_found_store => -"fun offset x -> Printf.printf ""found offset = %ld\n"" (Camlcoq.camlint_of_coqint offset); x". - -(* Asm *) -(* -Extract Constant Asm.low_half => "fun _ _ _ -> assert false". -Extract Constant Asm.high_half => "fun _ _ _ -> assert false". -*) diff --git a/mppa_k1c/lib/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v deleted file mode 100644 index 1af59238..00000000 --- a/mppa_k1c/lib/Asmblockgenproof0.v +++ /dev/null @@ -1,982 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* Xavier Leroy INRIA Paris-Rocquencourt *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(** * "block" version of Asmgenproof0 - - This module is largely adapted from Asmgenproof0.v of the other backends - It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends - It has similar definitions than Asmgenproof0, but adapted to this new structure *) - -Require Import Coqlib. -Require Intv. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Locations. -Require Import Machblock. -Require Import Asmblock. -Require Import Asmblockgen. -Require Import Conventions1. -Require Import Axioms. -Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *) -Require Import Asmblockprops. - -Module MB:=Machblock. -Module AB:=Asmblock. - -Lemma ireg_of_eq: - forall r r', ireg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold ireg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma freg_of_eq: - forall r r', freg_of r = OK r' -> preg_of r = IR r'. -Proof. - unfold freg_of; intros. destruct (preg_of r); inv H; auto. -Qed. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -Lemma undef_regs_other: - forall r rl rs, - (forall r', In r' rl -> r <> r') -> - undef_regs rl rs r = rs r. -Proof. - induction rl; simpl; intros. auto. - rewrite IHrl by auto. rewrite Pregmap.gso; auto. -Qed. - -Fixpoint preg_notin (r: preg) (rl: list mreg) : Prop := - match rl with - | nil => True - | r1 :: nil => r <> preg_of r1 - | r1 :: rl => r <> preg_of r1 /\ preg_notin r rl - end. - -Remark preg_notin_charact: - forall r rl, - preg_notin r rl <-> (forall mr, In mr rl -> r <> preg_of mr). -Proof. - induction rl; simpl; intros. - tauto. - destruct rl. - simpl. split. intros. intuition congruence. auto. - rewrite IHrl. split. - intros [A B]. intros. destruct H. congruence. auto. - auto. -Qed. - -Lemma undef_regs_other_2: - forall r rl rs, - preg_notin r rl -> - undef_regs (map preg_of rl) rs r = rs r. -Proof. - intros. apply undef_regs_other. intros. - exploit list_in_map_inv; eauto. intros [mr [A B]]. subst. - rewrite preg_notin_charact in H. auto. -Qed. - -(** * Agreement between Mach registers and processor registers *) - -Record agree (ms: Mach.regset) (sp: val) (rs: AB.regset) : Prop := mkagree { - agree_sp: rs#SP = sp; - agree_sp_def: sp <> Vundef; - agree_mregs: forall r: mreg, Val.lessdef (ms r) (rs#(preg_of r)) -}. - -Lemma preg_val: - forall ms sp rs r, agree ms sp rs -> Val.lessdef (ms r) rs#(preg_of r). -Proof. - intros. destruct H. auto. -Qed. - -Lemma preg_vals: - forall ms sp rs, agree ms sp rs -> - forall l, Val.lessdef_list (map ms l) (map rs (map preg_of l)). -Proof. - induction l; simpl. constructor. constructor. eapply preg_val; eauto. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, agree ms sp rs -> sp = rs#SP. -Proof. - intros. destruct H; auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r r', - agree ms sp rs -> - ireg_of r = OK r' -> - Val.lessdef (ms r) rs#r'. -Proof. - intros. rewrite <- (ireg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma freg_val: - forall ms sp rs r r', - agree ms sp rs -> - freg_of r = OK r' -> - Val.lessdef (ms r) (rs#r'). -Proof. - intros. rewrite <- (freg_of_eq _ _ H0). eapply preg_val; eauto. -Qed. - -Lemma agree_exten: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, data_preg r = true -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H0; auto. auto. - intros. rewrite H0; auto. apply preg_of_data. -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite H1; auto. apply not_eq_sym. apply preg_of_not_SP. - intros. unfold Mach.Regmap.set. destruct (Mach.RegEq.eq r0 r). congruence. - rewrite H1. auto. apply preg_of_data. - red; intros; elim n. eapply preg_of_injective; eauto. -Qed. - -Corollary agree_set_mreg_parallel: - forall ms sp rs r v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.Regmap.set r v ms) sp (Pregmap.set (preg_of r) v' rs). -Proof. - intros. eapply agree_set_mreg; eauto. rewrite Pregmap.gss; auto. intros; apply Pregmap.gso; auto. -Qed. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - data_preg r = false -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten with rs. auto. - intros. apply Pregmap.gso. congruence. -Qed. - -Lemma agree_nextblock: - forall ms sp rs b, - agree ms sp rs -> agree ms sp (nextblock b rs). -Proof. - intros. unfold nextblock. apply agree_set_other. auto. auto. -Qed. - -Lemma agree_set_pair: - forall sp p v v' ms rs, - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_pair p v ms) sp (set_pair (map_rpair preg_of p) v' rs). -Proof. - intros. destruct p; simpl. -- apply agree_set_mreg_parallel; auto. -- apply agree_set_mreg_parallel. apply agree_set_mreg_parallel; auto. - apply Val.hiword_lessdef; auto. apply Val.loword_lessdef; auto. -Qed. - -Lemma agree_undef_nondata_regs: - forall ms sp rl rs, - agree ms sp rs -> - (forall r, In r rl -> data_preg r = false) -> - agree ms sp (undef_regs rl rs). -Proof. - induction rl; simpl; intros. auto. - apply IHrl. apply agree_exten with rs; auto. - intros. apply Pregmap.gso. red; intros; subst. - assert (data_preg a = false) by auto. congruence. - intros. apply H0; auto. -Qed. - -Lemma agree_undef_regs: - forall ms sp rl rs rs', - agree ms sp rs -> - (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.undef_regs rl ms) sp rs'. -Proof. - intros. destruct H. split; auto. - rewrite <- agree_sp0. apply H0; auto. - rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP. - intros. destruct (In_dec mreg_eq r rl). - rewrite Mach.undef_regs_same; auto. - rewrite Mach.undef_regs_other; auto. rewrite H0; auto. - apply preg_of_data. - rewrite preg_notin_charact. intros; red; intros. elim n. - exploit preg_of_injective; eauto. congruence. -Qed. - -Lemma agree_set_undef_mreg: - forall ms sp rs r v rl rs', - agree ms sp rs -> - Val.lessdef v (rs'#(preg_of r)) -> - (forall r', data_preg r' = true -> r' <> preg_of r -> preg_notin r' rl -> rs'#r' = rs#r') -> - agree (Mach.Regmap.set r v (Mach.undef_regs rl ms)) sp rs'. -Proof. - intros. apply agree_set_mreg with (rs'#(preg_of r) <- (rs#(preg_of r))); auto. - apply agree_undef_regs with rs; auto. - intros. unfold Pregmap.set. destruct (PregEq.eq r' (preg_of r)). - congruence. auto. - intros. rewrite Pregmap.gso; auto. -Qed. - -Lemma agree_undef_caller_save_regs: - forall ms sp rs, - agree ms sp rs -> - agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs). -Proof. - intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split. -- unfold proj_sumbool; rewrite dec_eq_true. auto. -- auto. -- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP). - destruct (List.in_dec preg_eq (preg_of r) (List.map preg_of (List.filter is_callee_save all_mregs))); simpl. -+ apply list_in_map_inv in i. destruct i as (mr & A & B). - assert (r = mr) by (apply preg_of_injective; auto). subst mr; clear A. - apply List.filter_In in B. destruct B as [C D]. rewrite D. auto. -+ destruct (is_callee_save r) eqn:CS; auto. - elim n. apply List.in_map. apply List.filter_In. auto using all_mregs_complete. -Qed. - -Lemma agree_change_sp: - forall ms sp rs sp', - agree ms sp rs -> sp' <> Vundef -> - agree ms sp' (rs#SP <- sp'). -Proof. - intros. inv H. split; auto. - intros. rewrite Pregmap.gso; auto with asmgen. -Qed. - -(** Connection between Mach and Asm calling conventions for external - functions. *) - -Lemma extcall_arg_match: - forall ms sp rs m m' l v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg ms m sp l v -> - exists v', AB.extcall_arg rs m' l v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. - exists (rs#(preg_of r)); split. constructor. eapply preg_val; eauto. - unfold Mach.load_stack in H2. - exploit Mem.loadv_extends; eauto. intros [v' [A B]]. - rewrite (sp_val _ _ _ H) in A. - exists v'; split; auto. - econstructor. eauto. assumption. -Qed. - -Lemma extcall_arg_pair_match: - forall ms sp rs m m' p v, - agree ms sp rs -> - Mem.extends m m' -> - Mach.extcall_arg_pair ms m sp p v -> - exists v', AB.extcall_arg_pair rs m' p v' /\ Val.lessdef v v'. -Proof. - intros. inv H1. -- exploit extcall_arg_match; eauto. intros (v' & A & B). exists v'; split; auto. constructor; auto. -- exploit extcall_arg_match. eauto. eauto. eexact H2. intros (v1 & A1 & B1). - exploit extcall_arg_match. eauto. eauto. eexact H3. intros (v2 & A2 & B2). - exists (Val.longofwords v1 v2); split. constructor; auto. apply Val.longofwords_lessdef; auto. -Qed. - - -Lemma extcall_args_match: - forall ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall ll vl, - list_forall2 (Mach.extcall_arg_pair ms m sp) ll vl -> - exists vl', list_forall2 (AB.extcall_arg_pair rs m') ll vl' /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros. - exists (@nil val); split. constructor. constructor. - exploit extcall_arg_pair_match; eauto. intros [v1' [A B]]. - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. -Qed. - -Lemma extcall_arguments_match: - forall ms m m' sp rs sg args, - agree ms sp rs -> Mem.extends m m' -> - Mach.extcall_arguments ms m sp sg args -> - exists args', AB.extcall_arguments rs m' sg args' /\ Val.lessdef_list args args'. -Proof. - unfold Mach.extcall_arguments, AB.extcall_arguments; intros. - eapply extcall_args_match; eauto. -Qed. - -Remark builtin_arg_match: - forall ge (rs: regset) sp m a v, - eval_builtin_arg ge (fun r => rs (preg_of r)) sp m a v -> - eval_builtin_arg ge rs sp m (map_builtin_arg preg_of a) v. -Proof. - induction 1; simpl; eauto with barg. -Qed. - -Lemma builtin_args_match: - forall ge ms sp rs m m', agree ms sp rs -> Mem.extends m m' -> - forall al vl, eval_builtin_args ge ms sp m al vl -> - exists vl', eval_builtin_args ge rs sp m' (map (map_builtin_arg preg_of) al) vl' - /\ Val.lessdef_list vl vl'. -Proof. - induction 3; intros; simpl. - exists (@nil val); split; constructor. - exploit (@eval_builtin_arg_lessdef _ ge ms (fun r => rs (preg_of r))); eauto. - intros; eapply preg_val; eauto. - intros (v1' & A & B). - destruct IHlist_forall2 as [vl' [C D]]. - exists (v1' :: vl'); split; constructor; auto. apply builtin_arg_match; auto. -Qed. - -Lemma agree_set_res: - forall res ms sp rs v v', - agree ms sp rs -> - Val.lessdef v v' -> - agree (Mach.set_res res v ms) sp (AB.set_res (map_builtin_res preg_of res) v' rs). -Proof. - induction res; simpl; intros. -- eapply agree_set_mreg; eauto. rewrite Pregmap.gss. auto. - intros. apply Pregmap.gso; auto. -- auto. -- apply IHres2. apply IHres1. auto. - apply Val.hiword_lessdef; auto. - apply Val.loword_lessdef; auto. -Qed. - -Lemma set_res_other: - forall r res v rs, - data_preg r = false -> - set_res (map_builtin_res preg_of res) v rs r = rs r. -Proof. - induction res; simpl; intros. -- apply Pregmap.gso. red; intros; subst r. rewrite preg_of_data in H; discriminate. -- auto. -- rewrite IHres2, IHres1; auto. -Qed. - -(* inspired from Mach *) - -Lemma find_label_tail: - forall lbl c c', MB.find_label lbl c = Some c' -> is_tail c' c. -Proof. - induction c; simpl; intros. discriminate. - destruct (MB.is_label lbl a). inv H. auto with coqlib. eauto with coqlib. -Qed. - -(* inspired from Asmgenproof0 *) - -(* ... skip ... *) - -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Inductive code_tail: Z -> bblocks -> bblocks -> Prop := - | code_tail_0: forall c, - code_tail 0 c c - | code_tail_S: forall pos bi c1 c2, - code_tail pos c1 c2 -> - code_tail (pos + (size bi)) (bi :: c1) c2. - -Lemma code_tail_pos: - forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. -Proof. - induction 1. omega. generalize (size_positive bi); intros; omega. -Qed. - -Lemma find_bblock_tail: - forall c1 bi c2 pos, - code_tail pos c1 (bi :: c2) -> - find_bblock pos c1 = Some bi. -Proof. - induction c1; simpl; intros. - inversion H. - destruct (zlt pos 0). generalize (code_tail_pos _ _ _ H); intro; omega. - destruct (zeq pos 0). subst pos. - inv H. auto. generalize (size_positive a) (code_tail_pos _ _ _ H4). intro; omega. - inv H. congruence. replace (pos0 + size a - size a) with pos0 by omega. - eauto. -Qed. - - -Local Hint Resolve code_tail_0 code_tail_S: core. - -Lemma code_tail_next: - forall fn ofs c0, - code_tail ofs fn c0 -> - forall bi c1, c0 = bi :: c1 -> code_tail (ofs + (size bi)) fn c1. -Proof. - induction 1; intros. - - subst; eauto. - - replace (pos + size bi + size bi0) with ((pos + size bi0) + size bi); eauto. - omega. -Qed. - -Lemma size_blocks_pos c: 0 <= size_blocks c. -Proof. - induction c as [| a l ]; simpl; try omega. - generalize (size_positive a); omega. -Qed. - -Remark code_tail_positive: - forall fn ofs c, - code_tail ofs fn c -> 0 <= ofs. -Proof. - induction 1; intros; simpl. - - omega. - - generalize (size_positive bi). omega. -Qed. - -Remark code_tail_size: - forall fn ofs c, - code_tail ofs fn c -> size_blocks fn = ofs + size_blocks c. -Proof. - induction 1; intros; simpl; try omega. -Qed. - -Remark code_tail_bounds fn ofs c: - code_tail ofs fn c -> 0 <= ofs <= size_blocks fn. -Proof. - intro H; - exploit code_tail_size; eauto. - generalize (code_tail_positive _ _ _ H), (size_blocks_pos c). - omega. -Qed. - -Local Hint Resolve code_tail_next: core. - -Lemma code_tail_next_int: - forall fn ofs bi c, - size_blocks fn <= Ptrofs.max_unsigned -> - code_tail (Ptrofs.unsigned ofs) fn (bi :: c) -> - code_tail (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr (size bi)))) fn c. -Proof. - intros. - exploit code_tail_size; eauto. - simpl; generalize (code_tail_positive _ _ _ H0), (size_positive bi), (size_blocks_pos c). - intros. - rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr. - - rewrite Ptrofs.unsigned_repr; eauto. - omega. - - rewrite Ptrofs.unsigned_repr; omega. -Qed. - -(** Predictor for return addresses in generated Asm code. - - The [return_address_offset] predicate defined here is used in the - semantics for Mach to determine the return addresses that are - stored in activation records. *) - -(** Consider a Mach function [f] and a sequence [c] of Mach instructions - representing the Mach code that remains to be executed after a - function call returns. The predicate [return_address_offset f c ofs] - holds if [ofs] is the integer offset of the PPC instruction - following the call in the Asm code obtained by translating the - code of [f]. Graphically: -<< - Mach function f |--------- Mcall ---------| - Mach code c | |--------| - | \ \ - | \ \ - | \ \ - Asm code | |--------| - Asm function |------------- Pcall ---------| - - <-------- ofs -------> ->> -*) - -Definition return_address_offset (f: MB.function) (c: MB.code) (ofs: ptrofs) : Prop := - forall tf tc, - transf_function f = OK tf -> - transl_blocks f c false = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc. - -Lemma transl_blocks_tail: - forall f c1 c2, is_tail c1 c2 -> - forall tc2 ep2, transl_blocks f c2 ep2 = OK tc2 -> - exists tc1, exists ep1, transl_blocks f c1 ep1 = OK tc1 /\ is_tail tc1 tc2. -Proof. - induction 1; simpl; intros. - exists tc2; exists ep2; split; auto with coqlib. - monadInv H0. exploit IHis_tail; eauto. intros (tc1 & ep1 & A & B). - exists tc1; exists ep1; split. auto. - eapply is_tail_trans with x0; eauto with coqlib. -Qed. - -Lemma is_tail_code_tail: - forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. -Proof. - induction 1; eauto. - destruct IHis_tail; eauto. -Qed. - -Section RETADDR_EXISTS. - -Hypothesis transf_function_inv: - forall f tf, transf_function f = OK tf -> - exists tc ep, transl_blocks f (Machblock.fn_code f) ep = OK tc /\ is_tail tc (fn_blocks tf). - -Hypothesis transf_function_len: - forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned. - - -Lemma return_address_exists: - forall b f c, is_tail (b :: c) f.(MB.fn_code) -> - exists ra, return_address_offset f c ra. -Proof. - intros. destruct (transf_function f) as [tf|] eqn:TF. - + exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1). - exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2). - monadInv TR2. - assert (TL3: is_tail x0 (fn_blocks tf)). - { apply is_tail_trans with tc1; auto. - apply is_tail_trans with (x++x0); auto. eapply is_tail_app. - } - exploit is_tail_code_tail. eexact TL3. intros [ofs CT]. - exists (Ptrofs.repr ofs). red; intros. - rewrite Ptrofs.unsigned_repr. congruence. - exploit code_tail_bounds; eauto. - intros; apply transf_function_len in TF. omega. - + exists Ptrofs.zero; red; intros. congruence. -Qed. - -End RETADDR_EXISTS. - -(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points - within the Asmblock code generated by translating Machblock function [f], - and [tc] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -Inductive transl_code_at_pc (ge: MB.genv): - val -> block -> MB.function -> MB.code -> bool -> AB.function -> AB.bblocks -> Prop := - transl_code_at_pc_intro: - forall b ofs f c ep tf tc, - Genv.find_funct_ptr ge b = Some(Internal f) -> - transf_function f = Errors.OK tf -> - transl_blocks f c ep = OK tc -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) tc -> - transl_code_at_pc ge (Vptr b ofs) b f c ep tf tc. - -Remark code_tail_no_bigger: - forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. -Proof. - induction 1; simpl; omega. -Qed. - -Remark code_tail_unique: - forall fn c pos pos', - code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. -Proof. - induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. - f_equal. eauto. -Qed. - -Lemma return_address_offset_correct: - forall ge b ofs fb f c tf tc ofs', - transl_code_at_pc ge (Vptr b ofs) fb f c false tf tc -> - return_address_offset f c ofs' -> - ofs' = ofs. -Proof. - intros. inv H. red in H0. - exploit code_tail_unique. eexact H12. eapply H0; eauto. intro. - rewrite <- (Ptrofs.repr_unsigned ofs). - rewrite <- (Ptrofs.repr_unsigned ofs'). - congruence. -Qed. - -(** The [find_label] function returns the code tail starting at the - given label. A connection with [code_tail] is then established. *) - -Fixpoint find_label (lbl: label) (c: bblocks) {struct c} : option bblocks := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos <= pos' <= pos + size_blocks c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - - intros. inv H. exists pos. split; auto. split. - replace (pos - pos) with 0 by omega. constructor. constructor; try omega. - generalize (size_blocks_pos c). generalize (size_positive a). omega. - - intros. generalize (IHc (pos+size a) c' H). intros [pos' [A [B C]]]. - exists pos'. split. auto. split. - replace (pos' - pos) with ((pos' - (pos + (size a))) + (size a)) by omega. - constructor. auto. generalize (size_positive a). omega. -Qed. - -(** Helper lemmas to reason about -- the "code is tail of" property -- correct translation of labels. *) - -Definition tail_nolabel (k c: bblocks) : Prop := - is_tail k c /\ forall lbl, find_label lbl c = find_label lbl k. - -Lemma tail_nolabel_refl: - forall c, tail_nolabel c c. -Proof. - intros; split. apply is_tail_refl. auto. -Qed. - -Lemma tail_nolabel_trans: - forall c1 c2 c3, tail_nolabel c2 c3 -> tail_nolabel c1 c2 -> tail_nolabel c1 c3. -Proof. - intros. destruct H; destruct H0; split. - eapply is_tail_trans; eauto. - intros. rewrite H1; auto. -Qed. - -Definition nolabel (b: bblock) := - match (header b) with nil => True | _ => False end. - -Hint Extern 1 (nolabel _) => exact I : labels. - -Lemma tail_nolabel_cons: - forall b c k, - nolabel b -> tail_nolabel k c -> tail_nolabel k (b :: c). -Proof. - intros. destruct H0. split. - constructor; auto. - intros. simpl. rewrite <- H1. destruct b as [hd bdy ex]; simpl in *. - destruct hd as [|l hd]; simpl in *. - - assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false). - { apply is_label_correct_false. simpl header. apply in_nil. } - rewrite H2. auto. - - contradiction. -Qed. - -Hint Resolve tail_nolabel_refl: labels. - -Ltac TailNoLabel := - eauto with labels; - match goal with - | [ |- tail_nolabel _ (_ :: _) ] => apply tail_nolabel_cons; [auto; exact I | TailNoLabel] - | [ H: Error _ = OK _ |- _ ] => discriminate - | [ H: assertion_failed = OK _ |- _ ] => discriminate - | [ H: OK _ = OK _ |- _ ] => inv H; TailNoLabel - | [ H: bind _ _ = OK _ |- _ ] => monadInv H; TailNoLabel - | [ H: (if ?x then _ else _) = OK _ |- _ ] => destruct x; TailNoLabel - | [ H: match ?x with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct x; TailNoLabel - | _ => idtac - end. - -Remark tail_nolabel_find_label: - forall lbl k c, tail_nolabel k c -> find_label lbl c = find_label lbl k. -Proof. - intros. destruct H. auto. -Qed. - -Remark tail_nolabel_is_tail: - forall k c, tail_nolabel k c -> is_tail k c. -Proof. - intros. destruct H. auto. -Qed. - -Lemma exec_body_pc: - forall ge l rs1 m1 rs2 m2, - exec_body ge l rs1 m1 = Next rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction l. - - intros. inv H. auto. - - intros until m2. intro EXEB. - inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate. - eapply IHl in H0. rewrite H0. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: function. - -(** Straight-line code is composed of processor instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: list instruction -> regset -> mem -> - list instruction -> regset -> mem -> Prop := - | exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_straight ((PBasic i1) ::g c) rs1 m1 c rs2 m2 - | exec_straight_step: - forall i c rs1 m1 rs2 m2 c' rs3 m3, - exec_basic_instr ge i rs1 m1 = Next rs2 m2 -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight ((PBasic i) :: c) rs1 m1 c' rs3 m3. - -Inductive exec_control_rel: option control -> bblock -> regset -> mem -> - regset -> mem -> Prop := - | exec_control_rel_intro: - forall rs1 m1 b rs1' ctl rs2 m2, - rs1' = nextblock b rs1 -> - exec_control ge fn ctl rs1' m1 = Next rs2 m2 -> - exec_control_rel ctl b rs1 m1 rs2 m2. - -Inductive exec_bblock_rel: bblock -> regset -> mem -> regset -> mem -> Prop := - | exec_bblock_rel_intro: - forall rs1 m1 b rs2 m2, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - exec_bblock_rel b rs1 m1 rs2 m2. - -Lemma exec_straight_body: - forall c l rs1 m1 rs2 m2, - exec_straight c rs1 m1 nil rs2 m2 -> - code_to_basics c = Some l -> - exec_body ge l rs1 m1 = Next rs2 m2. -Proof. - induction c as [|i c]. - - intros until m2. intros EXES CTB. inv EXES. - - intros until m2. intros EXES CTB. inv EXES. - + inv CTB. simpl. rewrite H6. auto. - + inv CTB. destruct (code_to_basics c); try discriminate. inv H0. eapply IHc in H7; eauto. - rewrite <- H7. simpl. rewrite H1. auto. -Qed. - -Lemma exec_straight_body2: - forall c rs1 m1 c' rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - exists body, - exec_body ge body rs1 m1 = Next rs2 m2 - /\ (basics_to_code body) ++g c' = c. -Proof. - intros until m2. induction 1. - - exists (i1::nil). split; auto. simpl. rewrite H. auto. - - destruct IHexec_straight as (bdy & EXEB & BTC). - exists (i:: bdy). split; simpl. - + rewrite H. auto. - + congruence. -Qed. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_two: - forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_straight (i1 ::g i2 ::g c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 -> - exec_basic_instr ge i2 rs2 m2 = Next rs3 m3 -> - exec_basic_instr ge i3 rs3 m3 = Next rs4 m4 -> - exec_straight (i1 ::g i2 ::g i3 ::g c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** Like exec_straight predicate, but on blocks *) - -Inductive exec_straight_blocks: bblocks -> regset -> mem -> - bblocks -> regset -> mem -> Prop := - | exec_straight_blocks_one: - forall b1 c rs1 m1 rs2 m2, - exec_bblock ge fn b1 rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b1)) -> - exec_straight_blocks (b1 :: c) rs1 m1 c rs2 m2 - | exec_straight_blocks_step: - forall b c rs1 m1 rs2 m2 c' rs3 m3, - exec_bblock ge fn b rs1 m1 = Next rs2 m2 -> - rs2#PC = Val.offset_ptr rs1#PC (Ptrofs.repr (size b)) -> - exec_straight_blocks c rs2 m2 c' rs3 m3 -> - exec_straight_blocks (b :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_blocks_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight_blocks c1 rs1 m1 c2 rs2 m2 -> - exec_straight_blocks c2 rs2 m2 c3 rs3 m3 -> - exec_straight_blocks c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_blocks_step with rs2 m2; auto. - apply exec_straight_blocks_step with rs2 m2; auto. -Qed. - -(** Linking exec_straight with exec_straight_blocks *) - -Lemma exec_straight_pc: - forall c c' rs1 m1 rs2 m2, - exec_straight c rs1 m1 c' rs2 m2 -> - rs2 PC = rs1 PC. -Proof. - induction c; intros; try (inv H; fail). - inv H. - - eapply exec_basic_instr_pc; eauto. - - rewrite (IHc c' rs3 m3 rs2 m2); auto. - erewrite exec_basic_instr_pc; eauto. -Qed. - -Lemma regset_same_assign (rs: regset) r: - rs # r <- (rs r) = rs. -Proof. - apply functional_extensionality. intros x. destruct (preg_eq x r); subst; Simpl. -Qed. - -Lemma exec_straight_through_singleinst: - forall a b rs1 m1 rs2 m2 rs2' m2' lb, - bblock_single_inst (PBasic a) = b -> - exec_straight (a ::g nil) rs1 m1 nil rs2 m2 -> - nextblock b rs2 = rs2' -> m2 = m2' -> - exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'. -Proof. - intros. subst. constructor 1. unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto. - simpl. rewrite regset_same_assign. auto. - simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto. -Qed. - -(** The following lemmas show that straight-line executions - (predicate [exec_straight_blocks]) correspond to correct Asm executions. *) - -Lemma exec_straight_steps_1: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - plus step ge (State rs m) E0 (State rs' m'). -Proof. - induction 1; intros. - apply plus_one. - econstructor; eauto. - eapply find_bblock_tail. eauto. - eapply plus_left'. - econstructor; eauto. - eapply find_bblock_tail. eauto. - apply IHexec_straight_blocks with b0 (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. - auto. - apply code_tail_next_int; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall c rs m c' rs' m', - exec_straight_blocks c rs m c' rs' m' -> - size_blocks (fn_blocks fn) <= Ptrofs.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr ge b = Some (Internal fn) -> - code_tail (Ptrofs.unsigned ofs) (fn_blocks fn) c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Ptrofs.unsigned ofs') (fn_blocks fn) c'. -Proof. - induction 1; intros. - exists (Ptrofs.add ofs (Ptrofs.repr (size b1))). split. - rewrite H0. rewrite H2. auto. - apply code_tail_next_int; auto. - apply IHexec_straight_blocks with (Ptrofs.add ofs (Ptrofs.repr (size b))). - auto. rewrite H0. rewrite H3. reflexivity. auto. - apply code_tail_next_int; auto. -Qed. - -End STRAIGHTLINE. - -(** * Properties of the Machblock call stack *) - -Section MATCH_STACK. - -Variable ge: MB.genv. - -Inductive match_stack: list MB.stackframe -> Prop := - | match_stack_nil: - match_stack nil - | match_stack_cons: forall fb sp ra c s f tf tc, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - transl_code_at_pc ge ra fb f c false tf tc -> - sp <> Vundef -> - match_stack s -> - match_stack (Stackframe fb sp ra c :: s). - -Lemma parent_sp_def: forall s, match_stack s -> parent_sp s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - auto. -Qed. - -Lemma parent_ra_def: forall s, match_stack s -> parent_ra s <> Vundef. -Proof. - induction 1; simpl. - unfold Vnullptr; destruct Archi.ptr64; congruence. - inv H0. congruence. -Qed. - -Lemma lessdef_parent_sp: - forall s v, - match_stack s -> Val.lessdef (parent_sp s) v -> v = parent_sp s. -Proof. - intros. inv H0. auto. exploit parent_sp_def; eauto. tauto. -Qed. - -Lemma lessdef_parent_ra: - forall s v, - match_stack s -> Val.lessdef (parent_ra s) v -> v = parent_ra s. -Proof. - intros. inv H0. auto. exploit parent_ra_def; eauto. tauto. -Qed. - -End MATCH_STACK. diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v deleted file mode 100644 index f79814f2..00000000 --- a/mppa_k1c/lib/ForwardSimulationBlock.v +++ /dev/null @@ -1,387 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -(*** - -Auxiliary lemmas on starN and forward_simulation -in order to prove the forward simulation of Mach -> Machblock. - -***) - -Require Import Relations. -Require Import Wellfounded. -Require Import Coqlib. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. - - -Local Open Scope nat_scope. - - -(** Auxiliary lemma on starN *) -Section starN_lemma. - -Variable L: semantics. - -Local Hint Resolve starN_refl starN_step Eapp_assoc: core. - -Lemma starN_split n s t s': - starN (step L) (globalenv L) n s t s' -> - forall m k, n=m+k -> - exists (t1 t2:trace) s0, starN (step L) (globalenv L) m s t1 s0 /\ starN (step L) (globalenv L) k s0 t2 s' /\ t=t1**t2. -Proof. - induction 1; simpl. - + intros m k H; assert (X: m=0); try omega. - assert (X0: k=0); try omega. - subst; repeat (eapply ex_intro); intuition eauto. - + intros m; destruct m as [| m']; simpl. - - intros k H2; subst; repeat (eapply ex_intro); intuition eauto. - - intros k H2. inversion H2. - exploit (IHstarN m' k); eauto. intro. - destruct H3 as (t5 & t6 & s0 & H5 & H6 & H7). - repeat (eapply ex_intro). - instantiate (1 := t6); instantiate (1 := t1 ** t5); instantiate (1 := s0). - intuition eauto. subst. auto. -Qed. - -Lemma starN_tailstep n s t1 s': - starN (step L) (globalenv L) n s t1 s' -> - forall (t t2:trace) s'', - Step L s' t2 s'' -> t = t1 ** t2 -> starN (step L) (globalenv L) (S n) s t s''. -Proof. - induction 1; simpl. - + intros t t1 s0; autorewrite with trace_rewrite. - intros; subst; eapply starN_step; eauto. - autorewrite with trace_rewrite; auto. - + intros. eapply starN_step; eauto. - intros; subst; autorewrite with trace_rewrite; auto. -Qed. - -End starN_lemma. - - - -(** General scheme from a "match_states" relation *) - -Section ForwardSimuBlock_REL. - -Variable L1 L2: semantics. - - -(** Hypothèses de la preuve *) - -Variable dist_end_block: state L1 -> nat. - -Hypothesis simu_mid_block: - forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). - -Hypothesis public_preserved: - forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. - -Variable match_states: state L1 -> state L2 -> Prop. - -Hypothesis match_initial_states: - forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. - -Hypothesis match_final_states: - forall s1 s2 r, final_state L1 s1 r -> match_states s1 s2 -> final_state L2 s2 r. - -Hypothesis final_states_end_block: - forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. - -Hypothesis simu_end_block: - forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> match_states s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states s1' s2'. - - -(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *) - -Local Hint Resolve starN_refl starN_step: core. - -Definition follows_in_block (head current: state L1): Prop := - dist_end_block head >= dist_end_block current - /\ starN (step L1) (globalenv L1) (minus (dist_end_block head) (dist_end_block current)) head E0 current. - -Lemma follows_in_block_step (head previous next: state L1): - forall t, follows_in_block head previous -> Step L1 previous t next -> (dist_end_block previous)<>0 -> follows_in_block head next. -Proof. - intros t [H1 H2] H3 H4. - destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. - constructor 1. - + omega. - + cutrewrite (dist_end_block head - dist_end_block next = S (dist_end_block head - dist_end_block previous)). - - eapply starN_tailstep; eauto. - - omega. -Qed. - -Lemma follows_in_block_init (head current: state L1): - forall t, Step L1 head t current -> (dist_end_block head)<>0 -> follows_in_block head current. -Proof. - intros t H3 H4. - destruct (simu_mid_block _ _ _ H3 H4) as [H5 H6]; subst. - constructor 1. - + omega. - + cutrewrite (dist_end_block head - dist_end_block current = 1). - - eapply starN_tailstep; eauto. - - omega. -Qed. - - -Record memostate := { - real: state L1; - memorized: option (state L1); - memo_star: forall head, memorized = Some head -> follows_in_block head real; - memo_final: forall r, final_state L1 real r -> memorized = None -}. - -Definition head (s: memostate): state L1 := - match memorized s with - | None => real s - | Some s' => s' - end. - -Lemma head_followed (s: memostate): follows_in_block (head s) (real s). -Proof. - destruct s as [rs ms Hs]. simpl. - destruct ms as [ms|]; unfold head; simpl; auto. - constructor 1. - omega. - cutrewrite ((dist_end_block rs - dist_end_block rs)%nat=O). - + apply starN_refl; auto. - + omega. -Qed. - -Inductive is_well_memorized (s s': memostate): Prop := - | StartBloc: - dist_end_block (real s) <> O -> - memorized s = None -> - memorized s' = Some (real s) -> - is_well_memorized s s' - | MidBloc: - dist_end_block (real s) <> O -> - memorized s <> None -> - memorized s' = memorized s -> - is_well_memorized s s' - | ExitBloc: - dist_end_block (real s) = O -> - memorized s' = None -> - is_well_memorized s s'. - -Local Hint Resolve StartBloc MidBloc ExitBloc: core. - -Definition memoL1 := {| - state := memostate; - genvtype := genvtype L1; - step := fun ge s t s' => - step L1 ge (real s) t (real s') - /\ is_well_memorized s s' ; - initial_state := fun s => initial_state L1 (real s) /\ memorized s = None; - final_state := fun s r => final_state L1 (real s) r; - globalenv:= globalenv L1; - symbolenv:= symbolenv L1 -|}. - - -(** Preuve des 2 forward simulations: L1 -> memoL1 et memoL1 -> L2 *) - -Lemma discr_dist_end s: - {dist_end_block s = O} + {dist_end_block s <> O}. -Proof. - destruct (dist_end_block s); simpl; intuition. -Qed. - -Lemma memo_simulation_step: - forall s1 t s1', Step L1 s1 t s1' -> - forall s2, s1 = (real s2) -> exists s2', Step memoL1 s2 t s2' /\ s1' = (real s2'). -Proof. - intros s1 t s1' H1 [rs2 ms2 Hmoi] H2. simpl in H2; subst. - destruct (discr_dist_end rs2) as [H3 | H3]. - + refine (ex_intro _ {|real:=s1'; memorized:=None |} _); simpl. - intuition. - + destruct ms2 as [s|]. - - refine (ex_intro _ {|real:=s1'; memorized:=Some s |} _); simpl. - intuition. - - refine (ex_intro _ {|real:=s1'; memorized:=Some rs2 |} _); simpl. - intuition. - Unshelve. - * intros; discriminate. - * intros; auto. - * intros head X; injection X; clear X; intros; subst. - eapply follows_in_block_step; eauto. - * intros r X; erewrite final_states_end_block in H3; intuition eauto. - * intros head X; injection X; clear X; intros; subst. - eapply follows_in_block_init; eauto. - * intros r X; erewrite final_states_end_block in H3; intuition eauto. -Qed. - -Lemma forward_memo_simulation_1: forward_simulation L1 memoL1. -Proof. - apply forward_simulation_step with (match_states:=fun s1 s2 => s1 = (real s2)); auto. - + intros s1 H; eapply ex_intro with (x:={|real:=s1; memorized:=None |}); simpl. - intuition. - + intros; subst; auto. - + intros; exploit memo_simulation_step; eauto. - Unshelve. - * intros; discriminate. - * auto. -Qed. - -Lemma forward_memo_simulation_2: forward_simulation memoL1 L2. -Proof. - unfold memoL1; simpl. - apply forward_simulation_opt with (measure:=fun s => dist_end_block (real s)) (match_states:=fun s1 s2 => match_states (head s1) s2); simpl; auto. - + intros s1 [H0 H1]; destruct (match_initial_states (real s1) H0). - unfold head; rewrite H1. - intuition eauto. - + intros s1 s2 r X H0; unfold head in X. - erewrite memo_final in X; eauto. - + intros s1 t s1' [H1 H2] s2 H; subst. - destruct H2 as [ H0 H2 H3 | H0 H2 H3 | H0 H2]. - - (* StartBloc *) - constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. - unfold head in * |- *. rewrite H2 in H. rewrite H3. rewrite H4. intuition. - - (* MidBloc *) - constructor 2. destruct (simu_mid_block (real s1) t (real s1')) as [H5 H4]; auto. - unfold head in * |- *. rewrite H3. rewrite H4. intuition. - destruct (memorized s1); simpl; auto. tauto. - - (* EndBloc *) - constructor 1. - destruct (simu_end_block (head s1) t (real s1') s2) as (s2' & H3 & H4); auto. - * destruct (head_followed s1) as [H4 H3]. - cutrewrite (dist_end_block (head s1) - dist_end_block (real s1) = dist_end_block (head s1)) in H3; try omega. - eapply starN_tailstep; eauto. - * unfold head; rewrite H2; simpl. intuition eauto. -Qed. - -Lemma forward_simulation_block_rel: forward_simulation L1 L2. -Proof. - eapply compose_forward_simulations. - eapply forward_memo_simulation_1. - apply forward_memo_simulation_2. -Qed. - - -End ForwardSimuBlock_REL. - - - -(* An instance of the previous scheme, when there is a translation from L1 states to L2 states - -Here, we do not require that the sequence of S2 states does exactly match the sequence of L1 states by trans_state. -This is because the exact matching is broken in Machblock on "goto" instruction (due to the find_label). - -However, the Machblock state after a goto remains "equivalent" to the trans_state of the Mach state in the sense of "equiv_on_next_step" below... - -*) - - -Section ForwardSimuBlock_TRANS. - -Variable L1 L2: semantics. - -Variable trans_state: state L1 -> state L2. - -Definition equiv_on_next_step (P Q: Prop) s2_a s2_b: Prop := - (P -> (forall t s', Step L2 s2_a t s' <-> Step L2 s2_b t s')) /\ (Q -> (forall r, (final_state L2 s2_a r) <-> (final_state L2 s2_b r))). - -Definition match_states s1 s2: Prop := - equiv_on_next_step (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 (trans_state s1). - -Lemma match_states_trans_state s1: match_states s1 (trans_state s1). -Proof. - unfold match_states, equiv_on_next_step. intuition. -Qed. - -Variable dist_end_block: state L1 -> nat. - -Hypothesis simu_mid_block: - forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). - -Hypothesis public_preserved: - forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. - -Hypothesis match_initial_states: - forall s1, initial_state L1 s1 -> exists s2, match_states s1 s2 /\ initial_state L2 s2. - -Hypothesis match_final_states: - forall s1 r, final_state L1 s1 r -> final_state L2 (trans_state s1) r. - -Hypothesis final_states_end_block: - forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. - -Hypothesis simu_end_block: - forall s1 t s1', starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> exists s2', Step L2 (trans_state s1) t s2' /\ match_states s1' s2'. - -Lemma forward_simulation_block_trans: forward_simulation L1 L2. -Proof. - eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states); try tauto. - + (* final_states *) intros s1 s2 r H1 [H2 H3]. rewrite H3; eauto. - + (* simu_end_block *) - intros s1 t s1' s2 H1 [H2a H2b]. exploit simu_end_block; eauto. - intros (s2' & H3 & H4); econstructor 1; intuition eauto. - rewrite H2a; auto. - inversion_clear H1. eauto. -Qed. - -End ForwardSimuBlock_TRANS. - - -(* another version with a relation [trans_state_R] instead of a function [trans_state] *) -Section ForwardSimuBlock_TRANS_R. - -Variable L1 L2: semantics. - -Variable trans_state_R: state L1 -> state L2 -> Prop. - -Definition match_states_R s1 s2: Prop := - exists s2', trans_state_R s1 s2' /\ equiv_on_next_step _ (exists t s1', Step L1 s1 t s1') (exists r, final_state L1 s1 r) s2 s2'. - -Lemma match_states_trans_state_R s1 s2: trans_state_R s1 s2 -> match_states_R s1 s2. -Proof. - unfold match_states, equiv_on_next_step. firstorder. -Qed. - -Variable dist_end_block: state L1 -> nat. - -Hypothesis simu_mid_block: - forall s1 t s1', Step L1 s1 t s1' -> (dist_end_block s1)<>0 -> t = E0 /\ dist_end_block s1=S (dist_end_block s1'). - -Hypothesis public_preserved: - forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. - -Hypothesis match_initial_states: - forall s1, initial_state L1 s1 -> exists s2, match_states_R s1 s2 /\ initial_state L2 s2. - -Hypothesis match_final_states: - forall s1 s2 r, final_state L1 s1 r -> trans_state_R s1 s2 -> final_state L2 s2 r. - -Hypothesis final_states_end_block: - forall s1 t s1' r, Step L1 s1 t s1' -> final_state L1 s1' r -> dist_end_block s1 = 0. - -Hypothesis simu_end_block: - forall s1 t s1' s2, starN (step L1) (globalenv L1) (S (dist_end_block s1)) s1 t s1' -> trans_state_R s1 s2 -> exists s2', Step L2 s2 t s2' /\ match_states_R s1' s2'. - -Lemma forward_simulation_block_trans_R: forward_simulation L1 L2. -Proof. - eapply forward_simulation_block_rel with (dist_end_block:=dist_end_block) (match_states:=match_states_R); try tauto. - + (* final_states *) intros s1 s2 r H1 (s2' & H2 & H3 & H4). rewrite H4; eauto. - + (* simu_end_block *) - intros s1 t s1' s2 H1 (s2' & H2 & H2a & H2b). exploit simu_end_block; eauto. - intros (x & Hx & (y & H3 & H4 & H5)). repeat (econstructor; eauto). - rewrite H2a; eauto. - inversion_clear H1. eauto. -Qed. - -End ForwardSimuBlock_TRANS_R. - diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v deleted file mode 100644 index 08e0eba2..00000000 --- a/mppa_k1c/lib/Machblock.v +++ /dev/null @@ -1,380 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. - -(** basic instructions (ie no control-flow) *) -Inductive basic_inst: Type := - | MBgetstack: ptrofs -> typ -> mreg -> basic_inst - | MBsetstack: mreg -> ptrofs -> typ -> basic_inst - | MBgetparam: ptrofs -> typ -> mreg -> basic_inst - | MBop: operation -> list mreg -> mreg -> basic_inst - | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst - | MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst - . - -Definition bblock_body := list basic_inst. - -(** control flow instructions *) -Inductive control_flow_inst: Type := - | MBcall: signature -> mreg + ident -> control_flow_inst - | MBtailcall: signature -> mreg + ident -> control_flow_inst - | MBbuiltin: external_function -> list (builtin_arg mreg) -> builtin_res mreg -> control_flow_inst - | MBgoto: label -> control_flow_inst - | MBcond: condition -> list mreg -> label -> control_flow_inst - | MBjumptable: mreg -> list label -> control_flow_inst - | MBreturn: control_flow_inst - . - -Record bblock := mk_bblock { - header: list label; - body: bblock_body; - exit: option control_flow_inst -}. - -Lemma bblock_eq: - forall b1 b2, - header b1 = header b2 -> - body b1 = body b2 -> - exit b1 = exit b2 -> - b1 = b2. -Proof. - intros. destruct b1. destruct b2. - simpl in *. subst. auto. -Qed. - -Definition length_opt {A} (o: option A) : nat := - match o with - | Some o => 1 - | None => 0 - end. - -Definition size (b:bblock): nat := (length (header b))+(length (body b))+(length_opt (exit b)). - -Lemma size_null b: - size b = 0%nat -> - header b = nil /\ body b = nil /\ exit b = None. -Proof. - destruct b as [h b e]. simpl. unfold size. simpl. - intros H. - assert (length h = 0%nat) as Hh; [ omega |]. - assert (length b = 0%nat) as Hb; [ omega |]. - assert (length_opt e = 0%nat) as He; [ omega|]. - repeat split. - destruct h; try (simpl in Hh; discriminate); auto. - destruct b; try (simpl in Hb; discriminate); auto. - destruct e; try (simpl in He; discriminate); auto. -Qed. - -Definition code := list bblock. - -Record function: Type := mkfunction - { fn_sig: signature; - fn_code: code; - fn_stacksize: Z; - fn_link_ofs: ptrofs; - fn_retaddr_ofs: ptrofs }. - -Definition fundef := AST.fundef function. - -Definition program := AST.program fundef unit. - -Definition genv := Genv.t fundef unit. - -(*** sémantique ***) - -Lemma in_dec (lbl: label) (l: list label): { List.In lbl l } + { ~(List.In lbl l) }. -Proof. - apply List.in_dec. - apply Pos.eq_dec. -Qed. - -Definition is_label (lbl: label) (bb: bblock) : bool := - if in_dec lbl (header bb) then true else false. - -Lemma is_label_correct_true lbl bb: - List.In lbl (header bb) <-> is_label lbl bb = true. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - -Lemma is_label_correct_false lbl bb: - ~(List.In lbl (header bb)) <-> is_label lbl bb = false. -Proof. - unfold is_label; destruct (in_dec lbl (header bb)); simpl; intuition. -Qed. - - -Local Open Scope nat_scope. - -Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := - match c with - | nil => None - | bb1 :: bbl => if is_label lbl bb1 then Some c else find_label lbl bbl - end. - -Section RELSEM. - -Variable rao:function -> code -> ptrofs -> Prop. -Variable ge:genv. - -Definition find_function_ptr - (ge: genv) (ros: mreg + ident) (rs: regset) : option block := - match ros with - | inl r => - match rs r with - | Vptr b ofs => if Ptrofs.eq ofs Ptrofs.zero then Some b else None - | _ => None - end - | inr symb => - Genv.find_symbol ge symb - end. - -(** Machblock execution states. *) - -Inductive stackframe: Type := - | Stackframe: - forall (f: block) (**r pointer to calling function *) - (sp: val) (**r stack pointer in calling function *) - (retaddr: val) (**r Asm return address in calling function *) - (c: code), (**r program point in calling function *) - stackframe. - -Inductive state: Type := - | State: - forall (stack: list stackframe) (**r call stack *) - (f: block) (**r pointer to current function *) - (sp: val) (**r stack pointer *) - (c: code) (**r current program point *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state - | Callstate: - forall (stack: list stackframe) (**r call stack *) - (f: block) (**r pointer to function to call *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state - | Returnstate: - forall (stack: list stackframe) (**r call stack *) - (rs: regset) (**r register state *) - (m: mem), (**r memory state *) - state. - -Definition parent_sp (s: list stackframe) : val := - match s with - | nil => Vnullptr - | Stackframe f sp ra c :: s' => sp - end. - -Definition parent_ra (s: list stackframe) : val := - match s with - | nil => Vnullptr - | Stackframe f sp ra c :: s' => ra - end. - -Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:mem): basic_inst -> regset -> mem -> Prop := - | exec_MBgetstack: - forall ofs ty dst v, - load_stack m sp ty ofs = Some v -> - basic_step s fb sp rs m (MBgetstack ofs ty dst) (rs#dst <- v) m - | exec_MBsetstack: - forall src ofs ty m' rs', - store_stack m sp ty ofs (rs src) = Some m' -> - rs' = undef_regs (destroyed_by_setstack ty) rs -> - basic_step s fb sp rs m (MBsetstack src ofs ty) rs' m' - | exec_MBgetparam: - forall ofs ty dst v rs' f, - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (parent_sp s) ty ofs = Some v -> - rs' = (rs # temp_for_parent_frame <- Vundef # dst <- v) -> - basic_step s fb sp rs m (MBgetparam ofs ty dst) rs' m - | exec_MBop: - forall op args v rs' res, - eval_operation ge sp op rs##args m = Some v -> - rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) -> - basic_step s fb sp rs m (MBop op args res) rs' m - | exec_MBload: - forall addr args a v rs' trap chunk dst, - eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a = Some v -> - rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) -> - basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m - | exec_MBload_notrap1: - forall addr args rs' chunk dst, - eval_addressing ge sp addr rs##args = None -> - rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> - basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m - | exec_MBload_notrap2: - forall addr args a rs' chunk dst, - eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a = None -> - rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) -> - basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m - | exec_MBstore: - forall chunk addr args src m' a rs', - eval_addressing ge sp addr rs##args = Some a -> - Mem.storev chunk m a (rs src) = Some m' -> - rs' = undef_regs (destroyed_by_store chunk addr) rs -> - basic_step s fb sp rs m (MBstore chunk addr args src) rs' m' - . - - -Inductive body_step (s: list stackframe) (f: block) (sp: val): bblock_body -> regset -> mem -> regset -> mem -> Prop := - | exec_nil_body: - forall rs m, - body_step s f sp nil rs m rs m - | exec_cons_body: - forall rs m bi p rs' m' rs'' m'', - basic_step s f sp rs m bi rs' m' -> - body_step s f sp p rs' m' rs'' m'' -> - body_step s f sp (bi::p) rs m rs'' m'' - . - -Inductive cfi_step: control_flow_inst -> state -> trace -> state -> Prop := - | exec_MBcall: - forall s fb sp sig ros c b rs m f f' ra, - find_function_ptr ge ros rs = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - rao f c ra -> - cfi_step (MBcall sig ros) (State s fb sp (b::c) rs m) - E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) - f' rs m) - | exec_MBtailcall: - forall s fb stk soff sig ros c rs m f f' m', - find_function_ptr ge ros rs = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - cfi_step (MBtailcall sig ros) (State s fb (Vptr stk soff) c rs m) - E0 (Callstate s f' rs m') - | exec_MBbuiltin: - forall s f sp rs m ef args res b c vargs t vres rs' m', - eval_builtin_args ge rs sp m args vargs -> - external_call ef ge vargs m t vres m' -> - rs' = set_res res vres (undef_regs (destroyed_by_builtin ef) rs) -> - cfi_step (MBbuiltin ef args res) (State s f sp (b :: c) rs m) - t (State s f sp c rs' m') - | exec_MBgoto: - forall s fb f sp lbl c rs m c', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - cfi_step (MBgoto lbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs m) - | exec_MBcond_true: - forall s fb f sp cond args lbl c rs m c' rs', - eval_condition cond rs##args m = Some true -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - rs' = undef_regs (destroyed_by_cond cond) rs -> - cfi_step (MBcond cond args lbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs' m) - | exec_MBcond_false: - forall s f sp cond args lbl b c rs m rs', - eval_condition cond rs##args m = Some false -> - rs' = undef_regs (destroyed_by_cond cond) rs -> - cfi_step (MBcond cond args lbl) (State s f sp (b :: c) rs m) - E0 (State s f sp c rs' m) - | exec_MBjumptable: - forall s fb f sp arg tbl c rs m n lbl c' rs', - rs arg = Vint n -> - list_nth_z tbl (Int.unsigned n) = Some lbl -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - find_label lbl f.(fn_code) = Some c' -> - rs' = undef_regs destroyed_by_jumptable rs -> - cfi_step (MBjumptable arg tbl) (State s fb sp c rs m) - E0 (State s fb sp c' rs' m) - | exec_MBreturn: - forall s fb stk soff c rs m f m', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra s) -> - Mem.free m stk 0 f.(fn_stacksize) = Some m' -> - cfi_step MBreturn (State s fb (Vptr stk soff) c rs m) - E0 (Returnstate s rs m') - . - -Inductive exit_step: option control_flow_inst -> state -> trace -> state -> Prop := - | exec_Some_exit: - forall ctl s t s', - cfi_step ctl s t s' -> - exit_step (Some ctl) s t s' - | exec_None_exit: - forall stk f sp b lb rs m, - exit_step None (State stk f sp (b::lb) rs m) E0 (State stk f sp lb rs m) - . - -Inductive step: state -> trace -> state -> Prop := - | exec_bblock: - forall sf f sp bb c rs m rs' m' t s', - body_step sf f sp (body bb) rs m rs' m' -> - exit_step (exit bb) (State sf f sp (bb::c) rs' m') t s' -> - step (State sf f sp (bb::c) rs m) t s' - | exec_function_internal: - forall s fb rs m f m1 m2 m3 stk rs', - Genv.find_funct_ptr ge fb = Some (Internal f) -> - Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - let sp := Vptr stk Ptrofs.zero in - store_stack m1 sp Tptr f.(fn_link_ofs) (parent_sp s) = Some m2 -> - store_stack m2 sp Tptr f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> - rs' = undef_regs destroyed_at_function_entry rs -> - step (Callstate s fb rs m) - E0 (State s fb sp f.(fn_code) rs' m3) - | exec_function_external: - forall s fb rs m t rs' ef args res m', - Genv.find_funct_ptr ge fb = Some (External ef) -> - extcall_arguments rs m (parent_sp s) (ef_sig ef) args -> - external_call ef ge args m t res m' -> - rs' = set_pair (loc_result (ef_sig ef)) res (undef_caller_save_regs rs) -> - step (Callstate s fb rs m) - t (Returnstate s rs' m') - | exec_return: - forall s f sp ra c rs m, - step (Returnstate (Stackframe f sp ra c :: s) rs m) - E0 (State s f sp c rs m) - . - -End RELSEM. - -Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall fb m0, - let ge := Genv.globalenv p in - Genv.init_mem p = Some m0 -> - Genv.find_symbol ge p.(prog_main) = Some fb -> - initial_state p (Callstate nil fb (Regmap.init Vundef) m0). - -Inductive final_state: state -> int -> Prop := - | final_state_intro: forall rs m r retcode, - loc_result signature_main = One r -> - rs r = Vint retcode -> - final_state (Returnstate nil rs m) retcode. - -Definition semantics (rao: function -> code -> ptrofs -> Prop) (p: program) := - Semantics (step rao) (initial_state p) final_state (Genv.globalenv p). diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v deleted file mode 100644 index 287e4f7b..00000000 --- a/mppa_k1c/lib/Machblockgen.v +++ /dev/null @@ -1,216 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. -Require Import Machblock. - -Inductive Machblock_inst: Type := -| MB_label (lbl: label) -| MB_basic (bi: basic_inst) -| MB_cfi (cfi: control_flow_inst). - -Definition trans_inst (i:Mach.instruction) : Machblock_inst := - match i with - | Mcall sig ros => MB_cfi (MBcall sig ros) - | Mtailcall sig ros => MB_cfi (MBtailcall sig ros) - | Mbuiltin ef args res => MB_cfi (MBbuiltin ef args res) - | Mgoto lbl => MB_cfi (MBgoto lbl) - | Mcond cond args lbl => MB_cfi (MBcond cond args lbl) - | Mjumptable arg tbl => MB_cfi (MBjumptable arg tbl) - | Mreturn => MB_cfi (MBreturn) - | Mgetstack ofs ty dst => MB_basic (MBgetstack ofs ty dst) - | Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty) - | Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst) - | Mop op args res => MB_basic (MBop op args res) - | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst) - | Mstore chunk addr args src => MB_basic (MBstore chunk addr args src) - | Mlabel l => MB_label l - end. - -Definition empty_bblock:={| header := nil; body := nil; exit := None |}. -Extraction Inline empty_bblock. - -Definition add_label l bb:={| header := l::(header bb); body := (body bb); exit := (exit bb) |}. -Extraction Inline add_label. - -Definition add_basic bi bb :={| header := nil; body := bi::(body bb); exit := (exit bb) |}. -Extraction Inline add_basic. - -Definition cfi_bblock cfi:={| header := nil; body := nil; exit := Some cfi |}. -Extraction Inline cfi_bblock. - -Definition add_to_new_bblock (i:Machblock_inst) : bblock := - match i with - | MB_label l => add_label l empty_bblock - | MB_basic i => add_basic i empty_bblock - | MB_cfi i => cfi_bblock i - end. - -(** Adding an instruction to the beginning of a bblock list - * Either adding the instruction to the head of the list, - * or create a new bblock with the instruction *) -Definition add_to_code (i:Machblock_inst) (bl:code) : code := - match bl with - | bh::bl0 => match i with - | MB_label l => add_label l bh::bl0 - | MB_cfi i0 => cfi_bblock i0::bl - | MB_basic i0 => match header bh with - |_::_ => add_basic i0 empty_bblock::bl - | nil => add_basic i0 bh::bl0 - end - end - | _ => add_to_new_bblock i::nil - end. - -Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code := - match c with - | nil => bl - | i::c0 => - trans_code_rev c0 (add_to_code (trans_inst i) bl) - end. - -Function trans_code (c: Mach.code) : code := - trans_code_rev (List.rev_append c nil) nil. - -Definition transf_function (f: Mach.function) : function := - {| fn_sig:=Mach.fn_sig f; - fn_code:=trans_code (Mach.fn_code f); - fn_stacksize := Mach.fn_stacksize f; - fn_link_ofs := Mach.fn_link_ofs f; - fn_retaddr_ofs := Mach.fn_retaddr_ofs f - |}. - -Definition transf_fundef (f: Mach.fundef) : fundef := - transf_fundef transf_function f. - -Definition transf_program (src: Mach.program) : program := - transform_program transf_fundef src. - - -(** Abstracting trans_code *) - -Inductive is_end_block: Machblock_inst -> code -> Prop := - | End_empty mbi: is_end_block mbi nil - | End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl) - | End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl. - -Local Hint Resolve End_empty End_basic End_cfi: core. - -Inductive is_trans_code: Mach.code -> code -> Prop := - | Tr_nil: is_trans_code nil nil - | Tr_end_block i c bl: - is_trans_code c bl -> - is_end_block (trans_inst i) bl -> - is_trans_code (i::c) (add_to_new_bblock (trans_inst i)::bl) - | Tr_add_label i l bh c bl: - is_trans_code c (bh::bl) -> - i = Mlabel l -> - is_trans_code (i::c) (add_label l bh::bl) - | Tr_add_basic i bi bh c bl: - is_trans_code c (bh::bl) -> - trans_inst i = MB_basic bi -> - header bh = nil -> - is_trans_code (i::c) (add_basic bi bh::bl). - -Local Hint Resolve Tr_nil Tr_end_block: core. - -Lemma add_to_code_is_trans_code i c bl: - is_trans_code c bl -> - is_trans_code (i::c) (add_to_code (trans_inst i) bl). -Proof. - destruct bl as [|bh0 bl]; simpl. - - intro H. inversion H. subst. eauto. - - remember (trans_inst i) as ti. - destruct ti as [l|bi|cfi]. - + intros; eapply Tr_add_label; eauto. destruct i; simpl in * |- *; congruence. - + intros. remember (header bh0) as hbh0. destruct hbh0 as [|b]. - * eapply Tr_add_basic; eauto. - * cutrewrite (add_basic bi empty_bblock = add_to_new_bblock (MB_basic bi)); auto. - rewrite Heqti; eapply Tr_end_block; eauto. - rewrite <- Heqti. eapply End_basic. congruence. - + intros. - cutrewrite (cfi_bblock cfi = add_to_new_bblock (MB_cfi cfi)); auto. - rewrite Heqti. eapply Tr_end_block; eauto. - rewrite <- Heqti. eapply End_cfi. congruence. -Qed. - -Local Hint Resolve add_to_code_is_trans_code: core. - -Lemma trans_code_is_trans_code_rev c1: forall c2 mbi, - is_trans_code c2 mbi -> - is_trans_code (rev_append c1 c2) (trans_code_rev c1 mbi). -Proof. - induction c1 as [| i c1]; simpl; auto. -Qed. - -Lemma trans_code_is_trans_code c: is_trans_code c (trans_code c). -Proof. - unfold trans_code. - rewrite <- rev_alt. - rewrite <- (rev_involutive c) at 1. - rewrite rev_alt at 1. - apply trans_code_is_trans_code_rev; auto. -Qed. - -Lemma add_to_code_is_trans_code_inv i c bl: - is_trans_code (i::c) bl -> exists bl0, is_trans_code c bl0 /\ bl = add_to_code (trans_inst i) bl0. -Proof. - intro H; inversion H as [|H0 H1 bl0| | H0 bi bh H1 bl0]; clear H; subst; (repeat econstructor); eauto. - + (* case Tr_end_block *) inversion H3; subst; simpl; auto. - * destruct (header bh); congruence. - * destruct bl0; simpl; congruence. - + (* case Tr_add_basic *) rewrite H3. simpl. destruct (header bh); congruence. -Qed. - -Lemma trans_code_is_trans_code_rev_inv c1: forall c2 mbi, - is_trans_code (rev_append c1 c2) mbi -> - exists mbi0, is_trans_code c2 mbi0 /\ mbi=trans_code_rev c1 mbi0. -Proof. - induction c1 as [| i c1]; simpl; eauto. - intros; exploit IHc1; eauto. - intros (mbi0 & H1 & H2); subst. - exploit add_to_code_is_trans_code_inv; eauto. - intros. destruct H0 as [mbi1 [H2 H3]]. - exists mbi1. split; congruence. -Qed. - -Local Hint Resolve trans_code_is_trans_code: core. - -Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c). -Proof. - constructor; intros; subst; auto. - unfold trans_code. - exploit (trans_code_is_trans_code_rev_inv (rev_append c nil) nil bl); eauto. - * rewrite <- rev_alt. - rewrite <- rev_alt. - rewrite (rev_involutive c). - apply H. - * intros. - destruct H0 as [mbi [H0 H1]]. - inversion H0. subst. reflexivity. -Qed. diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v deleted file mode 100644 index dfb97bfe..00000000 --- a/mppa_k1c/lib/Machblockgenproof.v +++ /dev/null @@ -1,824 +0,0 @@ -(* *************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Sylvain Boulmé Grenoble-INP, VERIMAG *) -(* David Monniaux CNRS, VERIMAG *) -(* Cyril Six Kalray *) -(* *) -(* Copyright Kalray. Copyright VERIMAG. All rights reserved. *) -(* This file is distributed under the terms of the INRIA *) -(* Non-Commercial License Agreement. *) -(* *) -(* *************************************************************) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Stacklayout. -Require Import Mach. -Require Import Linking. -Require Import Machblock. -Require Import Machblockgen. -Require Import ForwardSimulationBlock. - -Ltac subst_is_trans_code H := - rewrite is_trans_code_inv in H; - rewrite <- H in * |- *; - rewrite <- is_trans_code_inv in H. - -Definition inv_trans_rao (rao: function -> code -> ptrofs -> Prop) (f: Mach.function) (c: Mach.code) := - rao (transf_function f) (trans_code c). - -Definition match_prog (p: Mach.program) (tp: Machblock.program) := - match_program (fun _ f tf => tf = transf_fundef f) eq p tp. - -Lemma transf_program_match: forall p tp, transf_program p = tp -> match_prog p tp. -Proof. - intros. rewrite <- H. eapply match_transform_program; eauto. -Qed. - -Definition trans_stackframe (msf: Mach.stackframe) : stackframe := - match msf with - | Mach.Stackframe f sp retaddr c => Stackframe f sp retaddr (trans_code c) - end. - -Fixpoint trans_stack (mst: list Mach.stackframe) : list stackframe := - match mst with - | nil => nil - | msf :: mst0 => (trans_stackframe msf) :: (trans_stack mst0) - end. - -Definition trans_state (ms: Mach.state): state := - match ms with - | Mach.State s f sp c rs m => State (trans_stack s) f sp (trans_code c) rs m - | Mach.Callstate s f rs m => Callstate (trans_stack s) f rs m - | Mach.Returnstate s rs m => Returnstate (trans_stack s) rs m - end. - -Section PRESERVATION. - -Local Open Scope nat_scope. - -Variable prog: Mach.program. -Variable tprog: Machblock.program. -Hypothesis TRANSF: match_prog prog tprog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - - -Variable rao: function -> code -> ptrofs -> Prop. - -Definition match_states: Mach.state -> state -> Prop - := ForwardSimulationBlock.match_states (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog) trans_state. - -Lemma match_states_trans_state s1: match_states s1 (trans_state s1). -Proof. - apply match_states_trans_state. -Qed. - -Local Hint Resolve match_states_trans_state: core. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_match TRANSF). - -Lemma senv_preserved: - Senv.equiv ge tge. -Proof (Genv.senv_match TRANSF). - -Lemma init_mem_preserved: - forall m, - Genv.init_mem prog = Some m -> - Genv.init_mem tprog = Some m. -Proof (Genv.init_mem_transf TRANSF). - -Lemma prog_main_preserved: - prog_main tprog = prog_main prog. -Proof (match_program_main TRANSF). - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = tf. -Proof. - intros. - exploit (Genv.find_funct_ptr_match TRANSF); eauto. intro. - destruct H0 as (cunit & tf & A & B & C). - eapply ex_intro. intuition; eauto. subst. eapply A. -Qed. - -Lemma find_function_ptr_same: - forall s rs, - Mach.find_function_ptr ge s rs = find_function_ptr tge s rs. -Proof. - intros. unfold Mach.find_function_ptr. unfold find_function_ptr. - destruct s; auto. - rewrite symbols_preserved; auto. -Qed. - -Lemma find_funct_ptr_same: - forall f f0, - Genv.find_funct_ptr ge f = Some (Internal f0) -> - Genv.find_funct_ptr tge f = Some (Internal (transf_function f0)). -Proof. - intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. -Qed. - -Lemma find_funct_ptr_same_external: - forall f f0, - Genv.find_funct_ptr ge f = Some (External f0) -> - Genv.find_funct_ptr tge f = Some (External f0). -Proof. - intros. exploit (Genv.find_funct_ptr_transf TRANSF); eauto. -Qed. - -Lemma parent_sp_preserved: - forall s, - Mach.parent_sp s = parent_sp (trans_stack s). -Proof. - unfold parent_sp. unfold Mach.parent_sp. destruct s; simpl; auto. - unfold trans_stackframe. destruct s; simpl; auto. -Qed. - -Lemma parent_ra_preserved: - forall s, - Mach.parent_ra s = parent_ra (trans_stack s). -Proof. - unfold parent_ra. unfold Mach.parent_ra. destruct s; simpl; auto. - unfold trans_stackframe. destruct s; simpl; auto. -Qed. - -Lemma external_call_preserved: - forall ef args m t res m', - external_call ef ge args m t res m' -> - external_call ef tge args m t res m'. -Proof. - intros. eapply external_call_symbols_preserved; eauto. - apply senv_preserved. -Qed. - -Lemma Mach_find_label_split l i c c': - Mach.find_label l (i :: c) = Some c' -> - (i=Mlabel l /\ c' = c) \/ (i <> Mlabel l /\ Mach.find_label l c = Some c'). -Proof. - intros H. - destruct i; try (constructor 2; split; auto; discriminate ). - destruct (peq l0 l) as [P|P]. - - constructor. subst l0; split; auto. - revert H. unfold Mach.find_label. simpl. rewrite peq_true. - intros H; injection H; auto. - - constructor 2. split. - + intro F. injection F. intros. contradict P; auto. - + revert H. unfold Mach.find_label. simpl. rewrite peq_false; auto. -Qed. - -Lemma find_label_is_end_block_not_label i l c bl: - is_end_block (trans_inst i) bl -> - is_trans_code c bl -> - i <> Mlabel l -> find_label l (add_to_new_bblock (trans_inst i) :: bl) = find_label l bl. -Proof. - intros H H0 H1. - unfold find_label. - remember (is_label l _) as b. - cutrewrite (b = false); auto. - subst; unfold is_label. - destruct i; simpl in * |- *; try (destruct (in_dec l nil); intuition). - inversion H. - destruct (in_dec l (l0::nil)) as [H6|H6]; auto. - simpl in H6; intuition try congruence. -Qed. - -Lemma find_label_at_begin l bh bl: - In l (header bh) - -> find_label l (bh :: bl) = Some (bh::bl). -Proof. - unfold find_label; rewrite is_label_correct_true; intro H; rewrite H; simpl; auto. -Qed. - -Lemma find_label_add_label_diff l bh bl: - ~(In l (header bh)) -> - find_label l (bh::bl) = find_label l bl. -Proof. - unfold find_label; rewrite is_label_correct_false; intro H; rewrite H; simpl; auto. -Qed. - -Definition concat (h: list label) (c: code): code := - match c with - | nil => {| header := h; body := nil; exit := None |}::nil - | b::c' => {| header := h ++ (header b); body := body b; exit := exit b |}::c' - end. - -Lemma find_label_transcode_preserved: - forall l c c', - Mach.find_label l c = Some c' -> - exists h, In l h /\ find_label l (trans_code c) = Some (concat h (trans_code c')). -Proof. - intros l c. remember (trans_code _) as bl. - rewrite <- is_trans_code_inv in * |-. - induction Heqbl. - + (* Tr_nil *) - intros; exists (l::nil); simpl in * |- *; intuition. - discriminate. - + (* Tr_end_block *) - intros. - exploit Mach_find_label_split; eauto. - clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. rewrite find_label_at_begin; simpl; auto. - inversion H as [mbi H1 H2| | ]. - subst. - inversion Heqbl. - subst. - exists (l :: nil); simpl; eauto. - - exploit IHHeqbl; eauto. - destruct 1 as (h & H3 & H4). - exists h. - split; auto. - erewrite find_label_is_end_block_not_label;eauto. - + (* Tr_add_label *) - intros. - exploit Mach_find_label_split; eauto. - clear H0; destruct 1 as [(H0&H2)|(H0&H2)]. - - subst. - inversion H0 as [H1]. - clear H0. - erewrite find_label_at_begin; simpl; eauto. - subst_is_trans_code Heqbl. - exists (l :: nil); simpl; eauto. - - subst; assert (H: l0 <> l); try congruence; clear H0. - exploit IHHeqbl; eauto. - clear IHHeqbl Heqbl. - intros (h & H3 & H4). - simpl; unfold is_label, add_label; simpl. - destruct (in_dec l (l0::header bh)) as [H5|H5]; simpl in H5. - * destruct H5; try congruence. - exists (l0::h); simpl; intuition. - rewrite find_label_at_begin in H4; auto. - apply f_equal. inversion H4 as [H5]. clear H4. - destruct (trans_code c'); simpl in * |- *; - inversion H5; subst; simpl; auto. - * exists h. intuition. - erewrite <- find_label_add_label_diff; eauto. - + (* Tr_add_basic *) - intros. - exploit Mach_find_label_split; eauto. - destruct 1 as [(H2&H3)|(H2&H3)]. - rewrite H2 in H. unfold trans_inst in H. congruence. - exploit IHHeqbl; eauto. - clear IHHeqbl Heqbl. - intros (h & H4 & H5). - rewrite find_label_add_label_diff; auto. - rewrite find_label_add_label_diff in H5; eauto. - rewrite H0; auto. -Qed. - -Lemma find_label_preserved: - forall l f c, - Mach.find_label l (Mach.fn_code f) = Some c -> - exists h, In l h /\ find_label l (fn_code (transf_function f)) = Some (concat h (trans_code c)). -Proof. - intros. cutrewrite ((fn_code (transf_function f)) = trans_code (Mach.fn_code f)); eauto. - apply find_label_transcode_preserved; auto. -Qed. - -Lemma mem_free_preserved: - forall m stk f, - Mem.free m stk 0 (Mach.fn_stacksize f) = Mem.free m stk 0 (fn_stacksize (transf_function f)). -Proof. - intros. auto. -Qed. - -Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated - parent_sp_preserved: core. - - -Definition dist_end_block_code (c: Mach.code) := - match trans_code c with - | nil => 0 - | bh::_ => (size bh-1)%nat - end. - -Definition dist_end_block (s: Mach.state): nat := - match s with - | Mach.State _ _ _ c _ _ => dist_end_block_code c - | _ => 0 - end. - -Local Hint Resolve exec_nil_body exec_cons_body: core. -Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core. - -Lemma size_add_label l bh: size (add_label l bh) = size bh + 1. -Proof. - unfold add_label, size; simpl; omega. -Qed. - -Lemma size_add_basic bi bh: header bh = nil -> size (add_basic bi bh) = size bh + 1. -Proof. - intro H. unfold add_basic, size; rewrite H; simpl. omega. -Qed. - - -Lemma size_add_to_newblock i: size (add_to_new_bblock i) = 1. -Proof. - destruct i; auto. -Qed. - - -Lemma dist_end_block_code_simu_mid_block i c: - dist_end_block_code (i::c) <> 0 -> - (dist_end_block_code (i::c) = Datatypes.S (dist_end_block_code c)). -Proof. - unfold dist_end_block_code. - remember (trans_code (i::c)) as bl. - rewrite <- is_trans_code_inv in Heqbl. - inversion Heqbl as [|bl0 H| |]; subst; clear Heqbl. - - rewrite size_add_to_newblock; omega. - - rewrite size_add_label; - subst_is_trans_code H. - omega. - - rewrite size_add_basic; auto. - subst_is_trans_code H. - omega. -Qed. - -Local Hint Resolve dist_end_block_code_simu_mid_block: core. - - -Lemma size_nonzero c b bl: - is_trans_code c (b :: bl) -> size b <> 0. -Proof. - intros H; inversion H; subst. - - rewrite size_add_to_newblock; omega. - - rewrite size_add_label; omega. - - rewrite size_add_basic; auto; omega. -Qed. - -Inductive is_header: list label -> Mach.code -> Mach.code -> Prop := - | header_empty : is_header nil nil nil - | header_not_label i c: (forall l, i <> Mlabel l) -> is_header nil (i::c) (i::c) - | header_is_label l h c c0: is_header h c c0 -> is_header (l::h) ((Mlabel l)::c) c0 - . - -Inductive is_body: list basic_inst -> Mach.code -> Mach.code -> Prop := - | body_empty : is_body nil nil nil - | body_not_bi i c: (forall bi, (trans_inst i) <> (MB_basic bi)) -> is_body nil (i::c) (i::c) - | body_is_bi i lbi c0 c1 bi: (trans_inst i) = MB_basic bi -> is_body lbi c0 c1 -> is_body (bi::lbi) (i::c0) c1 - . - -Inductive is_exit: option control_flow_inst -> Mach.code -> Mach.code -> Prop := - | exit_empty: is_exit None nil nil - | exit_not_cfi i c: (forall cfi, (trans_inst i) <> MB_cfi cfi) -> is_exit None (i::c) (i::c) - | exit_is_cfi i c cfi: (trans_inst i) = MB_cfi cfi -> is_exit (Some cfi) (i::c) c - . - -Lemma Mlabel_is_not_basic i: - forall bi, trans_inst i = MB_basic bi -> forall l, i <> Mlabel l. -Proof. -intros. -unfold trans_inst in H. -destruct i; congruence. -Qed. - -Lemma Mlabel_is_not_cfi i: - forall cfi, trans_inst i = MB_cfi cfi -> forall l, i <> Mlabel l. -Proof. -intros. -unfold trans_inst in H. -destruct i; congruence. -Qed. - -Lemma MBbasic_is_not_cfi i: - forall cfi, trans_inst i = MB_cfi cfi -> forall bi, trans_inst i <> MB_basic bi. -Proof. -intros. -unfold trans_inst in H. -unfold trans_inst. -destruct i; congruence. -Qed. - - -Local Hint Resolve Mlabel_is_not_cfi: core. -Local Hint Resolve MBbasic_is_not_cfi: core. - -Lemma add_to_new_block_is_label i: - header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l. -Proof. - intros. - unfold add_to_new_bblock in H. - destruct (trans_inst i) eqn : H1. - + exists lbl. - unfold trans_inst in H1. - destruct i; congruence. - + unfold add_basic in H; simpl in H; congruence. - + unfold cfi_bblock in H; simpl in H; congruence. -Qed. - -Local Hint Resolve Mlabel_is_not_basic: core. - -Lemma trans_code_decompose c: forall b bl, - is_trans_code c (b::bl) -> - exists c0 c1 c2, is_header (header b) c c0 /\ is_body (body b) c0 c1 /\ is_exit (exit b) c1 c2 /\ is_trans_code c2 bl. -Proof. - induction c as [|i c]. - { (* nil => absurd *) intros b bl H; inversion H. } - intros b bl H; remember (trans_inst i) as ti. - destruct ti as [lbl|bi|cfi]; - inversion H as [|d0 d1 d2 H0 H1| |]; subst; - try (rewrite <- Heqti in * |- *); simpl in * |- *; - try congruence. - + (* label at end block *) - inversion H1; subst. inversion H0; subst. - assert (X:i=Mlabel lbl). { destruct i; simpl in Heqti; congruence. } - subst. repeat econstructor; eauto. - + (* label at mid block *) - exploit IHc; eauto. - intros (c0 & c1 & c2 & H1 & H2 & H3 & H4). - repeat econstructor; eauto. - + (* basic at end block *) - inversion H1; subst. - lapply (Mlabel_is_not_basic i bi); auto. - intro H2. - - inversion H0; subst. - assert (X:(trans_inst i) = MB_basic bi ). { repeat econstructor; congruence. } - repeat econstructor; congruence. - - exists (i::c), c, c. - repeat econstructor; eauto; inversion H0; subst; repeat econstructor; simpl; try congruence. - * exploit (add_to_new_block_is_label i0); eauto. - intros (l & H8); subst; simpl; congruence. - * exploit H3; eauto. - * exploit (add_to_new_block_is_label i0); eauto. - intros (l & H8); subst; simpl; congruence. - + (* basic at mid block *) - inversion H1; subst. - exploit IHc; eauto. - intros (c0 & c1 & c2 & H3 & H4 & H5 & H6). - exists (i::c0), c1, c2. - repeat econstructor; eauto. - rewrite H2 in H3. - inversion H3; econstructor; eauto. - + (* cfi at end block *) - inversion H1; subst; - repeat econstructor; eauto. -Qed. - - -Lemma step_simu_header st f sp rs m s c h c' t: - is_header h c c' -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length h) (Mach.State st f sp c rs m) t s -> - s = Mach.State st f sp c' rs m /\ t = E0. -Proof. - induction 1; simpl; intros hs; try (inversion hs; tauto). - inversion hs as [|n1 s1 t1 t2 s2 t3 s3 H1]. inversion H1. subst. auto. -Qed. - - - -Lemma step_simu_basic_step (i: Mach.instruction) (bi: basic_inst) (c: Mach.code) s f sp rs m (t:trace) (s':Mach.state): - trans_inst i = MB_basic bi -> - Mach.step (inv_trans_rao rao) ge (Mach.State s f sp (i::c) rs m) t s' -> - exists rs' m', s'=Mach.State s f sp c rs' m' /\ t=E0 /\ basic_step tge (trans_stack s) f sp rs m bi rs' m'. -Proof. - destruct i; simpl in * |-; - (discriminate - || (intro H; inversion_clear H; intro X; inversion_clear X; eapply ex_intro; eapply ex_intro; intuition eauto)). - - eapply exec_MBgetparam; eauto. exploit (functions_translated); eauto. intro. - destruct H3 as (tf & A & B). subst. eapply A. - all: simpl; rewrite <- parent_sp_preserved; auto. - - eapply exec_MBop; eauto. rewrite <- H. destruct o; simpl; auto. destruct (rs ## l); simpl; auto. - unfold Genv.symbol_address; rewrite symbols_preserved; auto. - - eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; - unfold Genv.symbol_address; rewrite symbols_preserved; auto. - - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; - unfold Genv.symbol_address; rewrite symbols_preserved; auto. - - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; - unfold Genv.symbol_address; rewrite symbols_preserved; auto. - - eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto; - unfold Genv.symbol_address; rewrite symbols_preserved; auto. -Qed. - - -Lemma star_step_simu_body_step s f sp c bdy c': - is_body bdy c c' -> forall rs m t s', - starN (Mach.step (inv_trans_rao rao)) ge (length bdy) (Mach.State s f sp c rs m) t s' -> - exists rs' m', s'=Mach.State s f sp c' rs' m' /\ t=E0 /\ body_step tge (trans_stack s) f sp bdy rs m rs' m'. -Proof. - induction 1; simpl. - + intros. inversion H. exists rs. exists m. auto. - + intros. inversion H0. exists rs. exists m. auto. - + intros. inversion H1; subst. - exploit (step_simu_basic_step ); eauto. - destruct 1 as [ rs1 [ m1 Hs]]. - destruct Hs as [Hs1 [Hs2 Hs3]]. - destruct (IHis_body rs1 m1 t2 s') as [rs2 Hb]. rewrite <- Hs1; eauto. - destruct Hb as [m2 [Hb1 [Hb2 Hb3]]]. - exists rs2, m2. - rewrite Hs2, Hb2; eauto. - Qed. - -Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core. -Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core. - - -Lemma match_states_concat_trans_code st f sp c rs m h: - match_states (Mach.State st f sp c rs m) (State (trans_stack st) f sp (concat h (trans_code c)) rs m). -Proof. - intros; constructor 1; simpl. - + intros (t0 & s1' & H0) t s'. - remember (trans_code _) as bl. - destruct bl as [|bh bl]. - { rewrite <- is_trans_code_inv in Heqbl; inversion Heqbl; inversion H0; congruence. } - clear H0. - simpl; constructor 1; - intros X; inversion X as [d1 d2 d3 d4 d5 d6 d7 rs' m' d10 d11 X1 X2| | | ]; subst; simpl in * |- *; - eapply exec_bblock; eauto; simpl; - inversion X2 as [cfi d1 d2 d3 H1|]; subst; eauto; - inversion H1; subst; eauto. - + intros H r; constructor 1; intro X; inversion X. -Qed. - -Lemma step_simu_cfi_step (i: Mach.instruction) (cfi: control_flow_inst) (c: Mach.code) (blc:code) stk f sp rs m (t:trace) (s':Mach.state) b: - trans_inst i = MB_cfi cfi -> - is_trans_code c blc -> - Mach.step (inv_trans_rao rao) ge (Mach.State stk f sp (i::c) rs m) t s' -> - exists s2, cfi_step rao tge cfi (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s' s2. -Proof. - destruct i; simpl in * |-; - (intro H; intro Htc;apply is_trans_code_inv in Htc;rewrite Htc;inversion_clear H;intro X; inversion_clear X). - * eapply ex_intro. - intuition auto. - eapply exec_MBcall;eauto. - rewrite <-H; exploit (find_function_ptr_same); eauto. - * eapply ex_intro. - intuition auto. - eapply exec_MBtailcall;eauto. - - rewrite <-H; exploit (find_function_ptr_same); eauto. - - simpl; rewrite <- parent_sp_preserved; auto. - - simpl; rewrite <- parent_ra_preserved; auto. - * eapply ex_intro. - intuition auto. - eapply exec_MBbuiltin ;eauto. - * exploit find_label_transcode_preserved; eauto. - intros (x & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * exploit find_label_transcode_preserved; eauto. - intros (x & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBcond_false; eauto. - * exploit find_label_transcode_preserved; eauto. intros (h & X1 & X2). - eapply ex_intro; constructor 1; [ idtac | eapply match_states_concat_trans_code ]; eauto. - * eapply ex_intro; constructor 1; [ idtac | eapply match_states_trans_state ]; eauto. - eapply exec_MBreturn; eauto. - rewrite parent_sp_preserved in H0; subst; auto. - rewrite parent_ra_preserved in H1; subst; auto. -Qed. - -Lemma step_simu_exit_step stk f sp rs m t s1 e c c' b blc: - is_exit e c c' -> is_trans_code c' blc -> - starN (Mach.step (inv_trans_rao rao)) (Genv.globalenv prog) (length_opt e) (Mach.State stk f sp c rs m) t s1 -> - exists s2, exit_step rao tge e (State (trans_stack stk) f sp (b::blc) rs m) t s2 /\ match_states s1 s2. -Proof. - destruct 1. - - (* None *) - intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). - split; eauto. - apply is_trans_code_inv in H0. - rewrite H0. - apply match_states_trans_state. - - (* None *) - intros H0 H1. inversion H1. exists (State (trans_stack stk) f sp blc rs m). - split; eauto. - apply is_trans_code_inv in H0. - rewrite H0. - apply match_states_trans_state. - - (* Some *) - intros H0 H1. - inversion H1; subst. - exploit (step_simu_cfi_step); eauto. - intros [s2 [Hcfi1 Hcfi3]]. - inversion H4. subst; simpl. - autorewrite with trace_rewrite. - exists s2. - split;eauto. -Qed. - -Lemma simu_end_block: - forall s1 t s1', - starN (Mach.step (inv_trans_rao rao)) ge (Datatypes.S (dist_end_block s1)) s1 t s1' -> - exists s2', step rao tge (trans_state s1) t s2' /\ match_states s1' s2'. -Proof. - destruct s1; simpl. - + (* State *) - remember (trans_code _) as tc. - rewrite <- is_trans_code_inv in Heqtc. - intros t s1 H. - destruct tc as [|b bl]. - { (* nil => absurd *) - inversion Heqtc. subst. - unfold dist_end_block_code; simpl. - inversion_clear H; - inversion_clear H0. - } - assert (X: Datatypes.S (dist_end_block_code c) = (size b)). - { - unfold dist_end_block_code. - subst_is_trans_code Heqtc. - lapply (size_nonzero c b bl); auto. - omega. - } - rewrite X in H; unfold size in H. - (* decomposition of starN in 3 parts: header + body + exit *) - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H _ _ refl_equal) as (t3&t4&s1'&H0&H3&H4). - subst t; clear X H. - destruct (starN_split (Mach.semantics (inv_trans_rao rao) prog) _ _ _ _ H0 _ _ refl_equal) as (t1&t2&s1''&H&H1&H2). - subst t3; clear H0. - exploit trans_code_decompose; eauto. clear Heqtc. - intros (c0&c1&c2&Hc0&Hc1&Hc2&Heqtc). - (* header steps *) - exploit step_simu_header; eauto. - clear H; intros [X1 X2]; subst. - (* body steps *) - exploit (star_step_simu_body_step); eauto. - clear H1; intros (rs'&m'&H0&H1&H2). subst. - autorewrite with trace_rewrite. - (* exit step *) - exploit step_simu_exit_step; eauto. - clear H3; intros (s2' & H3 & H4). - eapply ex_intro; intuition eauto. - eapply exec_bblock; eauto. - + (* Callstate *) - intros t s1' H; inversion_clear H. - eapply ex_intro; constructor 1; eauto. - inversion H1; subst; clear H1. - inversion_clear H0; simpl. - - (* function_internal*) - cutrewrite (trans_code (Mach.fn_code f0) = fn_code (transf_function f0)); eauto. - eapply exec_function_internal; eauto. - rewrite <- parent_sp_preserved; eauto. - rewrite <- parent_ra_preserved; eauto. - - (* function_external *) - autorewrite with trace_rewrite. - eapply exec_function_external; eauto. - apply find_funct_ptr_same_external; auto. - rewrite <- parent_sp_preserved; eauto. - + (* Returnstate *) - intros t s1' H; inversion_clear H. - eapply ex_intro; constructor 1; eauto. - inversion H1; subst; clear H1. - inversion_clear H0; simpl. - eapply exec_return. -Qed. - - -Lemma cfi_dist_end_block i c: -(exists cfi, trans_inst i = MB_cfi cfi) -> -dist_end_block_code (i :: c) = 0. -Proof. - unfold dist_end_block_code. - intro H. destruct H as [cfi H]. - destruct i;simpl in H;try(congruence); ( - remember (trans_code _) as bl; - rewrite <- is_trans_code_inv in Heqbl; - inversion Heqbl; subst; simpl in * |- *; try (congruence)). -Qed. - -Theorem transf_program_correct: - forward_simulation (Mach.semantics (inv_trans_rao rao) prog) (Machblock.semantics rao tprog). -Proof. - apply forward_simulation_block_trans with (dist_end_block := dist_end_block) (trans_state := trans_state). -(* simu_mid_block *) - - intros s1 t s1' H1 H2. - destruct H1; simpl in * |- *; omega || (intuition auto); - destruct H2; eapply cfi_dist_end_block; simpl; eauto. -(* public_preserved *) - - apply senv_preserved. -(* match_initial_states *) - - intros. simpl. - eapply ex_intro; constructor 1. - eapply match_states_trans_state. - destruct H. split. - apply init_mem_preserved; auto. - rewrite prog_main_preserved. rewrite <- H0. apply symbols_preserved. -(* match_final_states *) - - intros. simpl. destruct H. split with (r := r); auto. -(* final_states_end_block *) - - intros. simpl in H0. - inversion H0. - inversion H; simpl; auto. - all: try (subst; discriminate). - apply cfi_dist_end_block; exists MBreturn; eauto. -(* simu_end_block *) - - apply simu_end_block. -Qed. - -End PRESERVATION. - -(** Auxiliary lemmas used to prove existence of a Mach return adress from a Machblock return address. *) - - - -Lemma is_trans_code_monotonic i c b l: - is_trans_code c (b::l) -> - exists l' b', is_trans_code (i::c) (l' ++ (b'::l)). -Proof. - intro H; destruct c as [|i' c]. { inversion H. } - remember (trans_inst i) as ti. - destruct ti as [lbl|bi|cfi]. - - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; simpl in * |- *; try congruence ). - exists nil; simpl; eexists. eapply Tr_add_label; eauto. - - (*i=basic*) - destruct i'. - 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b. - cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto. - rewrite Heqti. - eapply Tr_end_block; eauto. - rewrite <-Heqti. - eapply End_basic. inversion H; try(simpl; congruence). - simpl in H5; congruence. } - all: try(exists nil; simpl; eexists; eapply Tr_add_basic; eauto; inversion H; try(eauto || congruence)). - - (*i=cfi*) - destruct i; try(simpl in Heqti; congruence). - all: exists (add_to_new_bblock (MB_cfi cfi)::nil); exists b; - cutrewrite ((add_to_new_bblock (MB_cfi cfi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_cfi cfi) :: (b::l)));eauto; - rewrite Heqti; - eapply Tr_end_block; eauto; - rewrite <-Heqti; - eapply End_cfi; congruence. -Qed. - -Lemma trans_code_monotonic i c b l: - (b::l) = trans_code c -> - exists l' b', trans_code (i::c) = (l' ++ (b'::l)). -Proof. - intro H; rewrite <- is_trans_code_inv in H. - destruct (is_trans_code_monotonic i c b l H) as (l' & b' & H0). - subst_is_trans_code H0. - eauto. -Qed. - -(* FIXME: these two lemma should go into [Coqlib.v] *) -Lemma is_tail_app A (l1: list A): forall l2, is_tail l2 (l1 ++ l2). -Proof. - induction l1; simpl; auto with coqlib. -Qed. -Hint Resolve is_tail_app: coqlib. - -Lemma is_tail_app_inv A (l1: list A): forall l2 l3, is_tail (l1 ++ l2) l3 -> is_tail l2 l3. -Proof. - induction l1; simpl; auto with coqlib. - intros l2 l3 H; inversion H; eauto with coqlib. -Qed. -Hint Resolve is_tail_app_inv: coqlib. - - -Lemma Mach_Machblock_tail sg ros c c1 c2: c1=(Mcall sg ros :: c) -> is_tail c1 c2 -> - exists b, is_tail (b :: trans_code c) (trans_code c2). -Proof. - intros H; induction 1. - - intros; subst. - remember (trans_code (Mcall _ _::c)) as tc2. - rewrite <- is_trans_code_inv in Heqtc2. - inversion Heqtc2; simpl in * |- *; subst; try congruence. - subst_is_trans_code H1. - eapply ex_intro; eauto with coqlib. - - intros; exploit IHis_tail; eauto. clear IHis_tail. - intros (b & Hb). inversion Hb; clear Hb. - * exploit (trans_code_monotonic i c2); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - exists b'; simpl; eauto with coqlib. - * exploit (trans_code_monotonic i c2); eauto. - intros (l' & b' & Hl'); rewrite Hl'. - simpl; eapply ex_intro. - eapply is_tail_trans; eauto with coqlib. -Qed. - -Section Mach_Return_Address. - -Variable return_address_offset: function -> code -> ptrofs -> Prop. - -Hypothesis ra_exists: forall (b: bblock) (f: function) (c : list bblock), - is_tail (b :: c) (fn_code f) -> exists ra : ptrofs, return_address_offset f c ra. - -Definition Mach_return_address_offset (f: Mach.function) (c: Mach.code) (ofs: ptrofs) : Prop := - return_address_offset (transf_function f) (trans_code c) ofs. - -Lemma Mach_return_address_exists: - forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) -> - exists ra, Mach_return_address_offset f c ra. -Proof. - intros. - exploit Mach_Machblock_tail; eauto. - destruct 1. - eapply ra_exists; eauto. -Qed. - -End Mach_Return_Address. diff --git a/mppa_k1c/unittest/Makefile b/mppa_k1c/unittest/Makefile deleted file mode 100644 index 5e79efe4..00000000 --- a/mppa_k1c/unittest/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -# Needs to be called from CompCert root directory -# $ make -f mppa_k1c/unittest/Makefile postpass_test - -include Makefile.extr - -TEST_CMX=mppa_k1c/unittest/postpass_test.cmx - -UNITTEST_OBJS:=$(shell $(MODORDER) $(TEST_CMX)) - -postpass_test: $(UNITTEST_OBJS) - @echo "Linking $@ $(UNITTEST_OBJS)" - @$(OCAMLOPT) -o $@ $(LIBS) $(LINK_OPT) $+ - diff --git a/mppa_k1c/unittest/postpass_test.ml b/mppa_k1c/unittest/postpass_test.ml deleted file mode 100644 index 434bfaf7..00000000 --- a/mppa_k1c/unittest/postpass_test.ml +++ /dev/null @@ -1,12 +0,0 @@ -open Printf -open Asmblock -open Integers -open PostpassSchedulingOracle -open BinNums - -let test_schedule_sd = - let sd_inst = PStore (PStoreRRO (Psd, GPR12, GPR16, (Ofsimm (Ptrofs.of_int @@ Int.intval Z0)))) - in let bb = { header = []; body = [sd_inst]; exit = None } - in List.iter print_bb (smart_schedule bb) - -let _ = test_schedule_sd; printf "Done\n" diff --git a/runtime/Makefile b/runtime/Makefile index ebce458b..ea3c914f 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -22,12 +22,12 @@ ifeq ($(ARCH),x86_64) OBJS=i64_dtou.o i64_utod.o i64_utof.o vararg.o else ifeq ($(ARCH),powerpc64) OBJS=i64_dtou.o i64_stof.o i64_utod.o i64_utof.o vararg.o -else ifeq ($(ARCH),mppa_k1c) +else ifeq ($(ARCH),kvx) OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o \ i64_udivmod_stsud.o i32_divmod.o \ i64_utod.o i64_utof.o i64_stod.o i64_stof.o \ vararg.o -DOMAKE:=$(shell (cd mppa_k1c && make)) +DOMAKE:=$(shell (cd kvx && make)) else ifeq ($(ARCH),aarch64) OBJS=vararg.o else @@ -45,8 +45,8 @@ LIB=libcompcert.a INCLUDES=include/float.h include/stdarg.h include/stdbool.h \ include/stddef.h include/varargs.h include/stdalign.h \ include/stdnoreturn.h -ifeq ($(ARCH),mppa_k1c) -INCLUDES += include/ccomp_k1c_fixes.h include/math.h +ifeq ($(ARCH),kvx) +INCLUDES += include/ccomp_kvx_fixes.h include/math.h endif VPATH=$(ARCH) diff --git a/runtime/c/ccomp_k1c_fixes.h b/runtime/c/ccomp_k1c_fixes.h deleted file mode 120000 index b640c96e..00000000 --- a/runtime/c/ccomp_k1c_fixes.h +++ /dev/null @@ -1 +0,0 @@ -../include/ccomp_k1c_fixes.h \ No newline at end of file diff --git a/runtime/c/ccomp_kvx_fixes.h b/runtime/c/ccomp_kvx_fixes.h new file mode 120000 index 00000000..726d0f72 --- /dev/null +++ b/runtime/c/ccomp_kvx_fixes.h @@ -0,0 +1 @@ +../include/ccomp_kvx_fixes.h \ No newline at end of file diff --git a/runtime/include/ccomp_k1c_fixes.h b/runtime/include/ccomp_k1c_fixes.h deleted file mode 100644 index c884ae23..00000000 --- a/runtime/include/ccomp_k1c_fixes.h +++ /dev/null @@ -1,45 +0,0 @@ -/* *************************************************************/ -/* */ -/* The Compcert verified compiler */ -/* */ -/* Sylvain Boulmé Grenoble-INP, VERIMAG */ -/* David Monniaux CNRS, VERIMAG */ -/* Cyril Six Kalray */ -/* */ -/* Copyright Kalray. Copyright VERIMAG. All rights reserved. */ -/* This file is distributed under the terms of the INRIA */ -/* Non-Commercial License Agreement. */ -/* */ -/* *************************************************************/ - - -#ifndef __CCOMP_KIC_FIXES_H -#define __CCOMP_KIC_FIXES_H - -#if ! (defined(__COMPCERT__) && defined (__K1C__)) -#error This header is solely for CompCert on K1C -#endif - -#undef __GNUC__ -#define __thread _Thread_local - -struct __int128_ccomp { long __int128_ccomp_low; long __int128_ccomp_high; }; - -#define __int128 struct __int128_ccomp - -#define __builtin_k1_acswapd __compcert_acswapd -extern __int128 __compcert_acswapd(void *address, unsigned long long new_value, unsigned long long old_value); - -#define __builtin_k1_acswapw __compcert_acswapw -extern __int128 __compcert_acswapw(void *address, unsigned long long new_value, unsigned long long old_value); - -#define __builtin_k1_afaddd __compcert_afaddd -extern long long __compcert_afaddd(void *address, unsigned long long incr); - -#define __builtin_k1_afaddw __compcert_afaddw -extern int __compcert_afaddw(void *address, unsigned int incr); -#endif - -/* #define __builtin_expect(x, y) (x) */ -#define __builtin_ctz(x) __builtin_k1_ctzw(x) -#define __builtin_clz(x) __builtin_k1_clzw(x) diff --git a/runtime/include/ccomp_kvx_fixes.h b/runtime/include/ccomp_kvx_fixes.h new file mode 100644 index 00000000..65d65e7b --- /dev/null +++ b/runtime/include/ccomp_kvx_fixes.h @@ -0,0 +1,45 @@ +/* *************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* Sylvain Boulmé Grenoble-INP, VERIMAG */ +/* David Monniaux CNRS, VERIMAG */ +/* Cyril Six Kalray */ +/* */ +/* Copyright Kalray. Copyright VERIMAG. All rights reserved. */ +/* This file is distributed under the terms of the INRIA */ +/* Non-Commercial License Agreement. */ +/* */ +/* *************************************************************/ + + +#ifndef __CCOMP_KIC_FIXES_H +#define __CCOMP_KIC_FIXES_H + +#if ! (defined(__COMPCERT__) && defined (__KVX__)) +#error This header is solely for CompCert on KVX +#endif + +#undef __GNUC__ +#define __thread _Thread_local + +struct __int128_ccomp { long __int128_ccomp_low; long __int128_ccomp_high; }; + +#define __int128 struct __int128_ccomp + +#define __builtin_kvx_acswapd __compcert_acswapd +extern __int128 __compcert_acswapd(void *address, unsigned long long new_value, unsigned long long old_value); + +#define __builtin_kvx_acswapw __compcert_acswapw +extern __int128 __compcert_acswapw(void *address, unsigned long long new_value, unsigned long long old_value); + +#define __builtin_kvx_afaddd __compcert_afaddd +extern long long __compcert_afaddd(void *address, unsigned long long incr); + +#define __builtin_kvx_afaddw __compcert_afaddw +extern int __compcert_afaddw(void *address, unsigned int incr); +#endif + +/* #define __builtin_expect(x, y) (x) */ +#define __builtin_ctz(x) __builtin_kvx_ctzw(x) +#define __builtin_clz(x) __builtin_kvx_clzw(x) diff --git a/runtime/include/math.h b/runtime/include/math.h index 422787e1..e7c9e475 100644 --- a/runtime/include/math.h +++ b/runtime/include/math.h @@ -15,7 +15,7 @@ #ifndef _COMPCERT_MATH_H #define _COMPCERT_MATH_H -#ifdef __K1C__ +#ifdef __KVX__ #define isfinite(__y) (fpclassify((__y)) >= FP_ZERO) diff --git a/runtime/kvx/Makefile b/runtime/kvx/Makefile new file mode 100644 index 00000000..4e47f567 --- /dev/null +++ b/runtime/kvx/Makefile @@ -0,0 +1,15 @@ +CCOMP ?= ../../ccomp +CFLAGS ?= -O2 -D__K1_TINYK1__ + +CFILES=$(wildcard *.c) +SFILES=$(subst .c,.s,$(CFILES)) + +CCOMPPATH=$(shell which $(CCOMP)) + +all: $(SFILES) + +.SECONDARY: +%.s: %.c $(CCOMPPATH) + $(CCOMP) $(CFLAGS) -S $< -o $@ + sed -i -e 's/i64_/__compcert_i64_/g' -e 's/i32_/__compcert_i32_/g' \ + -e 's/f64_/__compcert_f64_/g' -e 's/f32_/__compcert_f32_/g' $@ diff --git a/runtime/kvx/ccomp_k1c_fixes.h b/runtime/kvx/ccomp_k1c_fixes.h new file mode 120000 index 00000000..b640c96e --- /dev/null +++ b/runtime/kvx/ccomp_k1c_fixes.h @@ -0,0 +1 @@ +../include/ccomp_k1c_fixes.h \ No newline at end of file diff --git a/runtime/kvx/i32_divmod.s b/runtime/kvx/i32_divmod.s new file mode 100644 index 00000000..9a6f0bce --- /dev/null +++ b/runtime/kvx/i32_divmod.s @@ -0,0 +1,120 @@ +/* KVX +32-bit unsigned/signed integer division/modulo (udiv5) + +D. Monniaux, CNRS, VERIMAG */ + + + .globl __compcert_i32_sdiv_fp +__compcert_i32_sdiv_fp: + compw.lt $r2 = $r0, 0 + compw.lt $r3 = $r1, 0 + absw $r0 = $r0 + absw $r1 = $r1 + ;; + xord $r2 = $r2, $r3 + make $r3 = 0 + goto __compcert_i32_divmod_fp + ;; + + .globl __compcert_i32_smod_fp +__compcert_i32_smod_fp: + compw.lt $r2 = $r0, 0 + absw $r0 = $r0 + absw $r1 = $r1 + make $r3 = 1 + goto __compcert_i32_divmod_fp + ;; + + .globl __compcert_i32_umod_fp +__compcert_i32_umod_fp: + make $r2 = 0 + make $r3 = 1 + goto __compcert_i32_divmod_fp + ;; + + .globl __compcert_i32_udiv_fp +__compcert_i32_udiv_fp: + make $r2 = 0 + make $r3 = 0 + ;; + +/* +r0 : a +r1 : b +r2 : negate result? +r3 : return mod? +*/ + + .globl __compcert_i32_divmod_fp +__compcert_i32_divmod_fp: + zxwd $r7 = $r1 + zxwd $r1 = $r0 +#ifndef NO_SHORTCUT + compw.ltu $r8 = $r0, $r1 + cb.weqz $r1? .ERR # return 0 if divide by 0 +#endif + ;; +# a in r1, b in r7 + floatud.rn.s $r5 = $r7, 0 +#ifndef NO_SHORTCUT + compd.eq $r8 = $r7, 1 + cb.wnez $r8? .LESS # shortcut if a < b +#endif + ;; +# b (double) in r5 + make $r6 = 0x3ff0000000000000 # 1.0 + fnarrowdw.rn.s $r11 = $r5 +# cb.wnez $r8, .RET1 # if b=1 + ;; +# b (single) in r11 + floatud.rn.s $r10 = $r1, 0 + finvw.rn.s $r11 = $r11 + ;; + fwidenlwd.s $r11 = $r11 + ;; +# invb0 in r11 + copyd $r9 = $r11 + ffmsd.rn.s $r6 = $r11, $r5 +# alpha in r6 + ;; + ffmad.rn.s $r9 = $r11, $r6 +# 1/b in r9 + ;; + fmuld.rn.s $r0 = $r10, $r9 +# a/b in r1 + ;; + fixedud.rn.s $r0 = $r0, 0 + ;; + msbfd $r1 = $r0, $r7 + ;; + addd $r6 = $r0, -1 + addd $r8 = $r1, $r7 + ;; + cmoved.dltz $r1? $r0 = $r6 + cmoved.dltz $r1? $r1 = $r8 + ;; + negw $r4 = $r0 + negw $r5 = $r1 + ;; + cmoved.wnez $r2? $r0 = $r4 + cmoved.wnez $r2? $r1 = $r5 + ;; +.END: + cmoved.wnez $r3? $r0 = $r1 + ret + ;; +#ifndef NO_SHORTCUT + +.LESS: + make $r0 = 0 + negw $r5 = $r1 + ;; + cmoved.wnez $r2? $r1 = $r5 + goto .END + ;; + +.ERR: + make $r0 = 0 + ret + ;; +#endif diff --git a/runtime/kvx/i64_sdiv.c b/runtime/kvx/i64_sdiv.c new file mode 100644 index 00000000..a42164cc --- /dev/null +++ b/runtime/kvx/i64_sdiv.c @@ -0,0 +1,23 @@ +extern long __divdi3 (long a, long b); + +int i32_sdiv (int a, int b) +{ + return __divdi3 (a, b); +} + +#ifdef OUR_OWN_FE_EXCEPT +#include <../../k1-cos/include/hal/cos_registers.h> + +/* DM FIXME this is for floating point */ +int fetestexcept(int excepts) { + int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts; + unsigned long long cs = __builtin_kvx_get(COS_SFR_CS); + return cs & mask; +} + +int feclearexcept(int excepts) { + int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts; + __builtin_kvx_wfxl(COS_SFR_CS, mask); + return 0; +} +#endif diff --git a/runtime/kvx/i64_smod.c b/runtime/kvx/i64_smod.c new file mode 100644 index 00000000..3371eecf --- /dev/null +++ b/runtime/kvx/i64_smod.c @@ -0,0 +1,5 @@ +extern long __moddi3 (long a, long b); +int i32_smod (int a, int b) +{ + return __moddi3 (a, b); +} diff --git a/runtime/kvx/i64_udiv.c b/runtime/kvx/i64_udiv.c new file mode 100644 index 00000000..75f4bbf5 --- /dev/null +++ b/runtime/kvx/i64_udiv.c @@ -0,0 +1,6 @@ +extern unsigned long __udivdi3 (unsigned long a, unsigned long b); + +unsigned i32_udiv (unsigned a, unsigned b) +{ + return __udivdi3 (a, b); +} diff --git a/runtime/kvx/i64_udivmod.c b/runtime/kvx/i64_udivmod.c new file mode 100644 index 00000000..952e47e5 --- /dev/null +++ b/runtime/kvx/i64_udivmod.c @@ -0,0 +1,30 @@ +#if 0 +/* THIS IS THE PREVIOUS VERSION, USED ON BOSTAN AND ANDEY */ +unsigned long long +udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) +{ + unsigned long long r = num, q = 0; + + if(den <= r) { + unsigned k = __builtin_clzll (den) - __builtin_clzll (r); + den = den << k; + if(r >= den) { + r = r - den; + q = 1LL << k; + } + if(k != 0) { + unsigned i = k; + den = den >> 1; + do { + r = __builtin_kvx_stsud (den, r); + i--; + } while (i!= 0); + q = q + r; + r = r >> k; + q = q - (r << k); + } + } + + return modwanted ? r : q; +} +#endif diff --git a/runtime/kvx/i64_udivmod_stsud.s b/runtime/kvx/i64_udivmod_stsud.s new file mode 100644 index 00000000..2dd73d66 --- /dev/null +++ b/runtime/kvx/i64_udivmod_stsud.s @@ -0,0 +1,218 @@ +/* +Integer division for KVX + +David Monniaux, CNRS / Verimag + */ + + .globl dm_udivmoddi4 +dm_udivmoddi4: + sxwd $r2 = $r2 + make $r5 = 0 + compd.ltu $r3 = $r0, $r1 + ;; + + clzd $r3 = $r1 + clzd $r4 = $r0 + cb.dnez $r3? .L74 + ;; + + sbfw $r4 = $r4, $r3 + ;; + + zxwd $r3 = $r4 + slld $r1 = $r1, $r4 + ;; + + compd.ltu $r6 = $r0, $r1 + ;; + + cb.dnez $r6? .L4C + ;; + + make $r5 = 1 + sbfd $r0 = $r1, $r0 + ;; + + slld $r5 = $r5, $r4 + ;; + +.L4C: + cb.deqz $r3? .L74 + ;; + + srld $r1 = $r1, 1 + zxwd $r3 = $r4 + ;; + + loopdo $r3, .LOOP + ;; + + stsud $r0 = $r1, $r0 + ;; + +.LOOP: + addd $r5 = $r0, $r5 + srld $r0 = $r0, $r4 + ;; + + slld $r4 = $r0, $r4 + ;; + + sbfd $r5 = $r4, $r5 + ;; + +.L74: + cmoved.deqz $r2? $r0 = $r5 + ret + ;; + +/* +r0 : a +r1 : b +r2 : negate result? +r3 : return mod? +*/ + + .globl __compcert_i32_sdiv_stsud +__compcert_i32_sdiv_stsud: + compw.lt $r2 = $r0, 0 + compw.lt $r3 = $r1, 0 + absw $r0 = $r0 + absw $r1 = $r1 + ;; + zxwd $r0 = $r0 + zxwd $r1 = $r1 + xord $r2 = $r2, $r3 + make $r3 = 0 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_smod_stsud +__compcert_i32_smod_stsud: + compw.lt $r2 = $r0, 0 + absw $r0 = $r0 + absw $r1 = $r1 + make $r3 = 1 + ;; + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_umod_stsud +__compcert_i32_umod_stsud: + make $r2 = 0 + make $r3 = 1 + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i32_udiv_stsud +__compcert_i32_udiv_stsud: + make $r2 = 0 + make $r3 = 0 + zxwd $r0 = $r0 + zxwd $r1 = $r1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_umod_stsud +__compcert_i64_umod_stsud: + make $r2 = 0 + make $r3 = 1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_udiv_stsud +__compcert_i64_udiv_stsud: + make $r2 = 0 + make $r3 = 0 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_sdiv_stsud +__compcert_i64_sdiv_stsud: + compd.lt $r2 = $r0, 0 + compd.lt $r3 = $r1, 0 + absd $r0 = $r0 + absd $r1 = $r1 + ;; + xord $r2 = $r2, $r3 + make $r3 = 0 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_smod_stsud +__compcert_i64_smod_stsud: + compd.lt $r2 = $r0, 0 + absd $r0 = $r0 + absd $r1 = $r1 + make $r3 = 1 + goto __compcert_i64_divmod_stsud + ;; + + .globl __compcert_i64_divmod_stsud +__compcert_i64_divmod_stsud: + make $r5 = 0 + compd.ltu $r7 = $r0, $r1 + ;; + + clzd $r7 = $r1 + clzd $r4 = $r0 + cb.dnez $r7? .ZL74 + ;; + + sbfw $r4 = $r4, $r7 + ;; + + zxwd $r7 = $r4 + slld $r1 = $r1, $r4 + ;; + + compd.ltu $r6 = $r0, $r1 + ;; + + cb.dnez $r6? .ZL4C + ;; + + make $r5 = 1 + sbfd $r0 = $r1, $r0 + ;; + + slld $r5 = $r5, $r4 + ;; + +.ZL4C: + cb.deqz $r7? .ZL74 + ;; + + srld $r1 = $r1, 1 + zxwd $r7 = $r4 + ;; + + loopdo $r7, .ZLOOP + ;; + + stsud $r0 = $r1, $r0 + ;; + +.ZLOOP: + addd $r5 = $r0, $r5 + srld $r0 = $r0, $r4 + ;; + + slld $r4 = $r0, $r4 + ;; + + sbfd $r5 = $r4, $r5 + ;; + +.ZL74: + cmoved.weqz $r3? $r0 = $r5 + ;; + negd $r5 = $r0 + ;; + cmoved.wnez $r2? $r0 = $r5 + ret + ;; diff --git a/runtime/kvx/i64_umod.c b/runtime/kvx/i64_umod.c new file mode 100644 index 00000000..59e35960 --- /dev/null +++ b/runtime/kvx/i64_umod.c @@ -0,0 +1,6 @@ +extern unsigned long __umoddi3 (unsigned long a, unsigned long b); + +unsigned i32_umod (unsigned a, unsigned b) +{ + return __umoddi3 (a, b); +} diff --git a/runtime/kvx/vararg.s b/runtime/kvx/vararg.s new file mode 100644 index 00000000..65c1eab8 --- /dev/null +++ b/runtime/kvx/vararg.s @@ -0,0 +1,54 @@ + +# typedef void * va_list; +# unsigned int __compcert_va_int32(va_list * ap); +# unsigned long long __compcert_va_int64(va_list * ap); + + .text + .balign 2 + .globl __compcert_va_int32 +__compcert_va_int32: + ld $r32 = 0[$r0] # $r32 <- *ap +;; + addd $r32 = $r32, 8 # $r32 <- $r32 + WORDSIZE +;; + sd 0[$r0] = $r32 # *ap <- $r32 +;; + lws $r0 = -8[$r32] # retvalue <- 32-bits at *ap - WORDSIZE + ret +;; + + .text + .balign 2 + .globl __compcert_va_int64 + .globl __compcert_va_float64 + .globl __compcert_va_composite +__compcert_va_int64: +__compcert_va_float64: +# FIXME this assumes pass-by-reference +__compcert_va_composite: +# Prologue + ld $r32 = 0[$r0] # $r32 <- *ap +;; + addd $r32 = $r32, 8 # $r32 <- $r32 + WORDSIZE +;; + sd 0[$r0] = $r32 # *ap <- $r32 +;; + ld $r0 = -8[$r32] # retvalue <- 64-bits at *ap - WORDSIZE + ret +;; + +# FIXME this assumes pass-by-reference + .globl __compcert_acswapd +__compcert_acswapd: + acswapd 0[$r1] = $r2r3 + ;; + sq 0[$r0] = $r2r3 + ret + ;; + .globl __compcert_acswapw +__compcert_acswapw: + acswapw 0[$r1] = $r2r3 + ;; + sq 0[$r0] = $r2r3 + ret + ;; diff --git a/runtime/mppa_k1c/Makefile b/runtime/mppa_k1c/Makefile deleted file mode 100644 index 4e47f567..00000000 --- a/runtime/mppa_k1c/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -CCOMP ?= ../../ccomp -CFLAGS ?= -O2 -D__K1_TINYK1__ - -CFILES=$(wildcard *.c) -SFILES=$(subst .c,.s,$(CFILES)) - -CCOMPPATH=$(shell which $(CCOMP)) - -all: $(SFILES) - -.SECONDARY: -%.s: %.c $(CCOMPPATH) - $(CCOMP) $(CFLAGS) -S $< -o $@ - sed -i -e 's/i64_/__compcert_i64_/g' -e 's/i32_/__compcert_i32_/g' \ - -e 's/f64_/__compcert_f64_/g' -e 's/f32_/__compcert_f32_/g' $@ diff --git a/runtime/mppa_k1c/ccomp_k1c_fixes.h b/runtime/mppa_k1c/ccomp_k1c_fixes.h deleted file mode 120000 index b640c96e..00000000 --- a/runtime/mppa_k1c/ccomp_k1c_fixes.h +++ /dev/null @@ -1 +0,0 @@ -../include/ccomp_k1c_fixes.h \ No newline at end of file diff --git a/runtime/mppa_k1c/i32_divmod.s b/runtime/mppa_k1c/i32_divmod.s deleted file mode 100644 index d2b4e8d5..00000000 --- a/runtime/mppa_k1c/i32_divmod.s +++ /dev/null @@ -1,120 +0,0 @@ -/* K1C -32-bit unsigned/signed integer division/modulo (udiv5) - -D. Monniaux, CNRS, VERIMAG */ - - - .globl __compcert_i32_sdiv_fp -__compcert_i32_sdiv_fp: - compw.lt $r2 = $r0, 0 - compw.lt $r3 = $r1, 0 - absw $r0 = $r0 - absw $r1 = $r1 - ;; - xord $r2 = $r2, $r3 - make $r3 = 0 - goto __compcert_i32_divmod_fp - ;; - - .globl __compcert_i32_smod_fp -__compcert_i32_smod_fp: - compw.lt $r2 = $r0, 0 - absw $r0 = $r0 - absw $r1 = $r1 - make $r3 = 1 - goto __compcert_i32_divmod_fp - ;; - - .globl __compcert_i32_umod_fp -__compcert_i32_umod_fp: - make $r2 = 0 - make $r3 = 1 - goto __compcert_i32_divmod_fp - ;; - - .globl __compcert_i32_udiv_fp -__compcert_i32_udiv_fp: - make $r2 = 0 - make $r3 = 0 - ;; - -/* -r0 : a -r1 : b -r2 : negate result? -r3 : return mod? -*/ - - .globl __compcert_i32_divmod_fp -__compcert_i32_divmod_fp: - zxwd $r7 = $r1 - zxwd $r1 = $r0 -#ifndef NO_SHORTCUT - compw.ltu $r8 = $r0, $r1 - cb.weqz $r1? .ERR # return 0 if divide by 0 -#endif - ;; -# a in r1, b in r7 - floatud.rn.s $r5 = $r7, 0 -#ifndef NO_SHORTCUT - compd.eq $r8 = $r7, 1 - cb.wnez $r8? .LESS # shortcut if a < b -#endif - ;; -# b (double) in r5 - make $r6 = 0x3ff0000000000000 # 1.0 - fnarrowdw.rn.s $r11 = $r5 -# cb.wnez $r8, .RET1 # if b=1 - ;; -# b (single) in r11 - floatud.rn.s $r10 = $r1, 0 - finvw.rn.s $r11 = $r11 - ;; - fwidenlwd.s $r11 = $r11 - ;; -# invb0 in r11 - copyd $r9 = $r11 - ffmsd.rn.s $r6 = $r11, $r5 -# alpha in r6 - ;; - ffmad.rn.s $r9 = $r11, $r6 -# 1/b in r9 - ;; - fmuld.rn.s $r0 = $r10, $r9 -# a/b in r1 - ;; - fixedud.rn.s $r0 = $r0, 0 - ;; - msbfd $r1 = $r0, $r7 - ;; - addd $r6 = $r0, -1 - addd $r8 = $r1, $r7 - ;; - cmoved.dltz $r1? $r0 = $r6 - cmoved.dltz $r1? $r1 = $r8 - ;; - negw $r4 = $r0 - negw $r5 = $r1 - ;; - cmoved.wnez $r2? $r0 = $r4 - cmoved.wnez $r2? $r1 = $r5 - ;; -.END: - cmoved.wnez $r3? $r0 = $r1 - ret - ;; -#ifndef NO_SHORTCUT - -.LESS: - make $r0 = 0 - negw $r5 = $r1 - ;; - cmoved.wnez $r2? $r1 = $r5 - goto .END - ;; - -.ERR: - make $r0 = 0 - ret - ;; -#endif diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c deleted file mode 100644 index b98d9316..00000000 --- a/runtime/mppa_k1c/i64_sdiv.c +++ /dev/null @@ -1,23 +0,0 @@ -extern long __divdi3 (long a, long b); - -int i32_sdiv (int a, int b) -{ - return __divdi3 (a, b); -} - -#ifdef OUR_OWN_FE_EXCEPT -#include <../../k1-cos/include/hal/cos_registers.h> - -/* DM FIXME this is for floating point */ -int fetestexcept(int excepts) { - int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts; - unsigned long long cs = __builtin_k1_get(COS_SFR_CS); - return cs & mask; -} - -int feclearexcept(int excepts) { - int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts; - __builtin_k1_wfxl(COS_SFR_CS, mask); - return 0; -} -#endif diff --git a/runtime/mppa_k1c/i64_smod.c b/runtime/mppa_k1c/i64_smod.c deleted file mode 100644 index 3371eecf..00000000 --- a/runtime/mppa_k1c/i64_smod.c +++ /dev/null @@ -1,5 +0,0 @@ -extern long __moddi3 (long a, long b); -int i32_smod (int a, int b) -{ - return __moddi3 (a, b); -} diff --git a/runtime/mppa_k1c/i64_udiv.c b/runtime/mppa_k1c/i64_udiv.c deleted file mode 100644 index 75f4bbf5..00000000 --- a/runtime/mppa_k1c/i64_udiv.c +++ /dev/null @@ -1,6 +0,0 @@ -extern unsigned long __udivdi3 (unsigned long a, unsigned long b); - -unsigned i32_udiv (unsigned a, unsigned b) -{ - return __udivdi3 (a, b); -} diff --git a/runtime/mppa_k1c/i64_udivmod.c b/runtime/mppa_k1c/i64_udivmod.c deleted file mode 100644 index ca48cd87..00000000 --- a/runtime/mppa_k1c/i64_udivmod.c +++ /dev/null @@ -1,30 +0,0 @@ -#if 0 -/* THIS IS THE PREVIOUS VERSION, USED ON BOSTAN AND ANDEY */ -unsigned long long -udivmoddi4(unsigned long long num, unsigned long long den, int modwanted) -{ - unsigned long long r = num, q = 0; - - if(den <= r) { - unsigned k = __builtin_clzll (den) - __builtin_clzll (r); - den = den << k; - if(r >= den) { - r = r - den; - q = 1LL << k; - } - if(k != 0) { - unsigned i = k; - den = den >> 1; - do { - r = __builtin_k1_stsud (den, r); - i--; - } while (i!= 0); - q = q + r; - r = r >> k; - q = q - (r << k); - } - } - - return modwanted ? r : q; -} -#endif diff --git a/runtime/mppa_k1c/i64_udivmod_stsud.s b/runtime/mppa_k1c/i64_udivmod_stsud.s deleted file mode 100644 index 50d0a767..00000000 --- a/runtime/mppa_k1c/i64_udivmod_stsud.s +++ /dev/null @@ -1,218 +0,0 @@ -/* -Integer division for K1c - -David Monniaux, CNRS / Verimag - */ - - .globl dm_udivmoddi4 -dm_udivmoddi4: - sxwd $r2 = $r2 - make $r5 = 0 - compd.ltu $r3 = $r0, $r1 - ;; - - clzd $r3 = $r1 - clzd $r4 = $r0 - cb.dnez $r3? .L74 - ;; - - sbfw $r4 = $r4, $r3 - ;; - - zxwd $r3 = $r4 - slld $r1 = $r1, $r4 - ;; - - compd.ltu $r6 = $r0, $r1 - ;; - - cb.dnez $r6? .L4C - ;; - - make $r5 = 1 - sbfd $r0 = $r1, $r0 - ;; - - slld $r5 = $r5, $r4 - ;; - -.L4C: - cb.deqz $r3? .L74 - ;; - - srld $r1 = $r1, 1 - zxwd $r3 = $r4 - ;; - - loopdo $r3, .LOOP - ;; - - stsud $r0 = $r1, $r0 - ;; - -.LOOP: - addd $r5 = $r0, $r5 - srld $r0 = $r0, $r4 - ;; - - slld $r4 = $r0, $r4 - ;; - - sbfd $r5 = $r4, $r5 - ;; - -.L74: - cmoved.deqz $r2? $r0 = $r5 - ret - ;; - -/* -r0 : a -r1 : b -r2 : negate result? -r3 : return mod? -*/ - - .globl __compcert_i32_sdiv_stsud -__compcert_i32_sdiv_stsud: - compw.lt $r2 = $r0, 0 - compw.lt $r3 = $r1, 0 - absw $r0 = $r0 - absw $r1 = $r1 - ;; - zxwd $r0 = $r0 - zxwd $r1 = $r1 - xord $r2 = $r2, $r3 - make $r3 = 0 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i32_smod_stsud -__compcert_i32_smod_stsud: - compw.lt $r2 = $r0, 0 - absw $r0 = $r0 - absw $r1 = $r1 - make $r3 = 1 - ;; - zxwd $r0 = $r0 - zxwd $r1 = $r1 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i32_umod_stsud -__compcert_i32_umod_stsud: - make $r2 = 0 - make $r3 = 1 - zxwd $r0 = $r0 - zxwd $r1 = $r1 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i32_udiv_stsud -__compcert_i32_udiv_stsud: - make $r2 = 0 - make $r3 = 0 - zxwd $r0 = $r0 - zxwd $r1 = $r1 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i64_umod_stsud -__compcert_i64_umod_stsud: - make $r2 = 0 - make $r3 = 1 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i64_udiv_stsud -__compcert_i64_udiv_stsud: - make $r2 = 0 - make $r3 = 0 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i64_sdiv_stsud -__compcert_i64_sdiv_stsud: - compd.lt $r2 = $r0, 0 - compd.lt $r3 = $r1, 0 - absd $r0 = $r0 - absd $r1 = $r1 - ;; - xord $r2 = $r2, $r3 - make $r3 = 0 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i64_smod_stsud -__compcert_i64_smod_stsud: - compd.lt $r2 = $r0, 0 - absd $r0 = $r0 - absd $r1 = $r1 - make $r3 = 1 - goto __compcert_i64_divmod_stsud - ;; - - .globl __compcert_i64_divmod_stsud -__compcert_i64_divmod_stsud: - make $r5 = 0 - compd.ltu $r7 = $r0, $r1 - ;; - - clzd $r7 = $r1 - clzd $r4 = $r0 - cb.dnez $r7? .ZL74 - ;; - - sbfw $r4 = $r4, $r7 - ;; - - zxwd $r7 = $r4 - slld $r1 = $r1, $r4 - ;; - - compd.ltu $r6 = $r0, $r1 - ;; - - cb.dnez $r6? .ZL4C - ;; - - make $r5 = 1 - sbfd $r0 = $r1, $r0 - ;; - - slld $r5 = $r5, $r4 - ;; - -.ZL4C: - cb.deqz $r7? .ZL74 - ;; - - srld $r1 = $r1, 1 - zxwd $r7 = $r4 - ;; - - loopdo $r7, .ZLOOP - ;; - - stsud $r0 = $r1, $r0 - ;; - -.ZLOOP: - addd $r5 = $r0, $r5 - srld $r0 = $r0, $r4 - ;; - - slld $r4 = $r0, $r4 - ;; - - sbfd $r5 = $r4, $r5 - ;; - -.ZL74: - cmoved.weqz $r3? $r0 = $r5 - ;; - negd $r5 = $r0 - ;; - cmoved.wnez $r2? $r0 = $r5 - ret - ;; diff --git a/runtime/mppa_k1c/i64_umod.c b/runtime/mppa_k1c/i64_umod.c deleted file mode 100644 index 59e35960..00000000 --- a/runtime/mppa_k1c/i64_umod.c +++ /dev/null @@ -1,6 +0,0 @@ -extern unsigned long __umoddi3 (unsigned long a, unsigned long b); - -unsigned i32_umod (unsigned a, unsigned b) -{ - return __umoddi3 (a, b); -} diff --git a/runtime/mppa_k1c/vararg.s b/runtime/mppa_k1c/vararg.s deleted file mode 100644 index 65c1eab8..00000000 --- a/runtime/mppa_k1c/vararg.s +++ /dev/null @@ -1,54 +0,0 @@ - -# typedef void * va_list; -# unsigned int __compcert_va_int32(va_list * ap); -# unsigned long long __compcert_va_int64(va_list * ap); - - .text - .balign 2 - .globl __compcert_va_int32 -__compcert_va_int32: - ld $r32 = 0[$r0] # $r32 <- *ap -;; - addd $r32 = $r32, 8 # $r32 <- $r32 + WORDSIZE -;; - sd 0[$r0] = $r32 # *ap <- $r32 -;; - lws $r0 = -8[$r32] # retvalue <- 32-bits at *ap - WORDSIZE - ret -;; - - .text - .balign 2 - .globl __compcert_va_int64 - .globl __compcert_va_float64 - .globl __compcert_va_composite -__compcert_va_int64: -__compcert_va_float64: -# FIXME this assumes pass-by-reference -__compcert_va_composite: -# Prologue - ld $r32 = 0[$r0] # $r32 <- *ap -;; - addd $r32 = $r32, 8 # $r32 <- $r32 + WORDSIZE -;; - sd 0[$r0] = $r32 # *ap <- $r32 -;; - ld $r0 = -8[$r32] # retvalue <- 64-bits at *ap - WORDSIZE - ret -;; - -# FIXME this assumes pass-by-reference - .globl __compcert_acswapd -__compcert_acswapd: - acswapd 0[$r1] = $r2r3 - ;; - sq 0[$r0] = $r2r3 - ret - ;; - .globl __compcert_acswapw -__compcert_acswapw: - acswapw 0[$r1] = $r2r3 - ;; - sq 0[$r0] = $r2r3 - ret - ;; diff --git a/test/Makefile b/test/Makefile index e9c5d6a1..c371e18a 100644 --- a/test/Makefile +++ b/test/Makefile @@ -3,7 +3,7 @@ include ../Makefile.config #DIRS=c compression raytracer spass regression # Kalray note - removing compression, raytracer and spass that cannot be executed by the simulator in reasonable time -ifeq ($(ARCH),mppa_k1c) +ifeq ($(ARCH),kvx) DIRS=c regression else DIRS=c compression raytracer spass regression diff --git a/test/c/Makefile b/test/c/Makefile index a2a80e06..726631d2 100644 --- a/test/c/Makefile +++ b/test/c/Makefile @@ -25,7 +25,7 @@ PROGS?=fib integr qsort fft fftsp fftw sha1 sha3 aes almabench \ # * also removed bisect, who is exhibiting different float values on the Kalray # architecture than using x86 GCC (for both CompCert and GCC ports) (tested with n=10) ## -ifeq ($(ARCH),mppa_k1c) +ifeq ($(ARCH),kvx) PROGS:=$(filter-out knucleotide,$(PROGS)) PROGS:=$(filter-out bisect,$(PROGS)) endif diff --git a/test/c/aes.c b/test/c/aes.c index 0a64fe60..c959a611 100644 --- a/test/c/aes.c +++ b/test/c/aes.c @@ -1441,7 +1441,7 @@ int main(int argc, char ** argv) (u8 *)"\x00\x11\x22\x33\x44\x55\x66\x77\x88\x99\xAA\xBB\xCC\xDD\xEE\xFF", (u8 *)"\x8E\xA2\xB7\xCA\x51\x67\x45\xBF\xEA\xFC\x49\x90\x4B\x49\x60\x89", 5, 6); -#ifdef __K1C__ +#ifdef __KVX__ do_bench(2000); #else do_bench(1000000); diff --git a/test/c/almabench.c b/test/c/almabench.c index 4417200c..823bc18f 100644 --- a/test/c/almabench.c +++ b/test/c/almabench.c @@ -45,7 +45,7 @@ #define sineps 0.3977771559319137 #define coseps 0.9174820620691818 -#ifdef __K1C__ +#ifdef __KVX__ #define TEST_LENGTH 12 #else #define TEST_LENGTH 36525 diff --git a/test/c/binarytrees.c b/test/c/binarytrees.c index becae164..fbcddea1 100644 --- a/test/c/binarytrees.c +++ b/test/c/binarytrees.c @@ -75,7 +75,7 @@ int main(int argc, char* argv[]) unsigned N, depth, minDepth, maxDepth, stretchDepth; treeNode *stretchTree, *longLivedTree, *tempTree; -#ifdef __K1C__ +#ifdef __KVX__ N = argc < 2 ? 6 : atol(argv[1]); #else N = argc < 2 ? 12 : atol(argv[1]); diff --git a/test/c/chomp.c b/test/c/chomp.c index 7e2f62c1..71931b3d 100644 --- a/test/c/chomp.c +++ b/test/c/chomp.c @@ -338,7 +338,7 @@ int main(void) struct _play *tree; -#ifdef __K1C__ +#ifdef __KVX__ ncol = 4; nrow = 4; #else diff --git a/test/c/fannkuch.c b/test/c/fannkuch.c index befccd8d..a075c988 100644 --- a/test/c/fannkuch.c +++ b/test/c/fannkuch.c @@ -102,7 +102,7 @@ fannkuch( int n ) int main( int argc, char* argv[] ) { -#ifdef __K1C__ +#ifdef __KVX__ int n = (argc>1) ? atoi(argv[1]) : 6; #else int n = (argc>1) ? atoi(argv[1]) : 10; diff --git a/test/c/fft.c b/test/c/fft.c index 8ab59c9a..3513319f 100644 --- a/test/c/fft.c +++ b/test/c/fft.c @@ -152,7 +152,7 @@ int main(int argc, char ** argv) double enp, t, y, z, zr, zi, zm, a; double * xr, * xi, * pxr, * pxi; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 10; #else if (argc >= 2) n = atoi(argv[1]); else n = 18; diff --git a/test/c/fftsp.c b/test/c/fftsp.c index d327a74c..3215dca5 100644 --- a/test/c/fftsp.c +++ b/test/c/fftsp.c @@ -153,7 +153,7 @@ int main(int argc, char ** argv) float enp, t, y, z, zr, zi, zm, a; float * xr, * xi, * pxr, * pxi; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 3; #else if (argc >= 2) n = atoi(argv[1]); else n = 12; diff --git a/test/c/fftw.c b/test/c/fftw.c index 04d896ad..2d50022a 100644 --- a/test/c/fftw.c +++ b/test/c/fftw.c @@ -74,7 +74,7 @@ const E KP1_847759065 = ((E) +1.847759065022573512256366378793576573644833252); /* Test harness */ -#ifdef __K1C__ +#ifdef __KVX__ #define NRUNS (10 * 10) #else #define NRUNS (100 * 1000) diff --git a/test/c/fib.c b/test/c/fib.c index 168626bc..536038bd 100644 --- a/test/c/fib.c +++ b/test/c/fib.c @@ -12,7 +12,7 @@ int fib(int n) int main(int argc, char ** argv) { int n, r; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 15; #else if (argc >= 2) n = atoi(argv[1]); else n = 35; diff --git a/test/c/integr.c b/test/c/integr.c index cd0521f5..edd87def 100644 --- a/test/c/integr.c +++ b/test/c/integr.c @@ -25,7 +25,7 @@ double test(int n) int main(int argc, char ** argv) { int n; double r; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 100000; #else if (argc >= 2) n = atoi(argv[1]); else n = 10000000; diff --git a/test/c/lists.c b/test/c/lists.c index 8deb0f37..b995f6d0 100644 --- a/test/c/lists.c +++ b/test/c/lists.c @@ -61,7 +61,7 @@ int main(int argc, char ** argv) int n, niter, i; struct list * l; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 500; if (argc >= 3) niter = atoi(argv[1]); else niter = 100; #else diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c index 548c3ffa..d862b1a3 100644 --- a/test/c/mandelbrot.c +++ b/test/c/mandelbrot.c @@ -17,7 +17,7 @@ int main (int argc, char **argv) { int w, h, bit_num = 0; char byte_acc = 0; -#ifdef __K1C__ +#ifdef __KVX__ int i, iter = 30; #else int i, iter = 50; @@ -26,7 +26,7 @@ int main (int argc, char **argv) double Zr, Zi, Cr, Ci, Tr, Ti; if (argc < 2) { -#ifdef __K1C__ +#ifdef __KVX__ w = h = 40; #else w = h = 1000; @@ -60,7 +60,7 @@ int main (int argc, char **argv) if(bit_num == 8) { putc(byte_acc,stdout); -#ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster +#ifdef __KVX__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); #endif byte_acc = 0; @@ -70,7 +70,7 @@ int main (int argc, char **argv) { byte_acc <<= (8-w%8); putc(byte_acc,stdout); -#ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster +#ifdef __KVX__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster fflush(stdout); #endif byte_acc = 0; diff --git a/test/c/nbody.c b/test/c/nbody.c index ab0ebabe..01b36d5a 100644 --- a/test/c/nbody.c +++ b/test/c/nbody.c @@ -140,7 +140,7 @@ void setup_bodies(void) int main(int argc, char ** argv) { -#ifdef __K1C__ +#ifdef __KVX__ int n = argc < 2 ? 100 : atoi(argv[1]); #else int n = argc < 2 ? 1000000 : atoi(argv[1]); diff --git a/test/c/nsieve.c b/test/c/nsieve.c index 3954bcbe..83e1e1f0 100644 --- a/test/c/nsieve.c +++ b/test/c/nsieve.c @@ -29,14 +29,14 @@ static unsigned int nsieve(int m) { #define NITER 2 int main(int argc, char * argv[]) { -#ifdef __K1C__ +#ifdef __KVX__ int m = argc < 2 ? 6 : atoi(argv[1]); #else int m = argc < 2 ? 9 : atoi(argv[1]); #endif int i, j; for (i = 0; i < 3; i++) { -#ifdef __K1C__ +#ifdef __KVX__ int n = 200 << (m-i); #else int n = 10000 << (m-i); diff --git a/test/c/nsievebits.c b/test/c/nsievebits.c index e3b7fd43..a723d6d8 100644 --- a/test/c/nsievebits.c +++ b/test/c/nsievebits.c @@ -30,7 +30,7 @@ nsieve(unsigned int m) return (count); } -#ifdef __K1C__ +#ifdef __KVX__ #define NITER 1 #else #define NITER 2 @@ -52,7 +52,7 @@ main(int ac, char **av) { unsigned int n; -#ifdef __K1C__ +#ifdef __KVX__ n = ac < 2 ? 2 : atoi(av[1]); #else n = ac < 2 ? 9 : atoi(av[1]); diff --git a/test/c/perlin.c b/test/c/perlin.c index 29ebf964..5fa83a81 100644 --- a/test/c/perlin.c +++ b/test/c/perlin.c @@ -63,7 +63,7 @@ static void init(void) { p[256+i] = p[i] = permutation[i]; } -#ifdef __K1C__ +#ifdef __KVX__ #define INCREMENT 0.5 #define MIN -3.0 #define MAX 3.0 diff --git a/test/c/qsort.c b/test/c/qsort.c index 1ebe1e11..298e131f 100644 --- a/test/c/qsort.c +++ b/test/c/qsort.c @@ -34,7 +34,7 @@ int main(int argc, char ** argv) int n, i, j; int * a, * b; -#ifdef __K1C__ +#ifdef __KVX__ if (argc >= 2) n = atoi(argv[1]); else n = 500; #else if (argc >= 2) n = atoi(argv[1]); else n = 100000; diff --git a/test/c/sha1.c b/test/c/sha1.c index 624030cc..ce827c4a 100644 --- a/test/c/sha1.c +++ b/test/c/sha1.c @@ -231,7 +231,7 @@ int main(int argc, char ** argv) } do_test(test_input_1, test_output_1); do_test(test_input_2, test_output_2); -#ifdef __K1C__ +#ifdef __KVX__ do_bench(500); #else do_bench(200000); diff --git a/test/c/sha3.c b/test/c/sha3.c index 164e3086..796162a5 100644 --- a/test/c/sha3.c +++ b/test/c/sha3.c @@ -190,7 +190,7 @@ test_triplet_t testvec[4] = { } }; -#ifdef __K1C__ +#ifdef __KVX__ #define DATALEN 1000 #define NITER 7 #else diff --git a/test/c/siphash24.c b/test/c/siphash24.c index ce0df78c..b4b4ff34 100644 --- a/test/c/siphash24.c +++ b/test/c/siphash24.c @@ -235,7 +235,7 @@ int test_vectors() u8 testdata[100] = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 12, 34, 56, 78, 90 }; -#ifdef __K1C__ +#ifdef __KVX__ #define NITER 1000 #else #define NITER 1000000 diff --git a/test/c/spectral.c b/test/c/spectral.c index dca78fe0..2d7604b2 100644 --- a/test/c/spectral.c +++ b/test/c/spectral.c @@ -43,7 +43,7 @@ void eval_AtA_times_u(int N, const double u[], double AtAu[]) int main(int argc, char *argv[]) { int i; -#ifdef __K1C__ +#ifdef __KVX__ int N = ((argc == 2) ? atoi(argv[1]) : 11); #else int N = ((argc == 2) ? atoi(argv[1]) : 1000); diff --git a/test/c/vmach.c b/test/c/vmach.c index 5858d4d6..56138104 100644 --- a/test/c/vmach.c +++ b/test/c/vmach.c @@ -159,7 +159,7 @@ long wordcode_interp(unsigned int* code) #define I(a,b,c,d) ((a) + ((b) << 8) + ((c) << 16) + ((d) << 24)) -#ifdef __K1C__ +#ifdef __KVX__ #define FIBSIZE 15 #else #define FIBSIZE 30 @@ -182,7 +182,7 @@ unsigned int wordcode_fib[] = { /* 13 */ I(WRETURN, 0, 2, 0) }; -#ifdef __K1C__ +#ifdef __KVX__ #define TAKSIZE1 6 #define TAKSIZE2 9 #define TAKSIZE3 12 diff --git a/test/endian.h b/test/endian.h index d6e121f4..204b69bc 100644 --- a/test/endian.h +++ b/test/endian.h @@ -1,7 +1,7 @@ #if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__) #define ARCH_BIG_ENDIAN #elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \ - || defined(__riscv) || defined(__aarch64__) || defined(__K1C__) + || defined(__riscv) || defined(__aarch64__) || defined(__KVX__) #undef ARCH_BIG_ENDIAN #else #error "unknown endianness" diff --git a/test/monniaux/.gitignore b/test/monniaux/.gitignore index c06c2984..4ebc3cde 100644 --- a/test/monniaux/.gitignore +++ b/test/monniaux/.gitignore @@ -1,5 +1,5 @@ **.host -**.k1c +**.kvx **measures.csv commands.txt @@ -7,7 +7,7 @@ oracle_times.txt verifier_times.txt compile_times.pdf measure_times.host.pdf -measure_times.k1c.pdf +measure_times.kvx.pdf /.mypy_cache/ diff --git a/test/monniaux/BearSSL/conf/KalrayCompCert.mk b/test/monniaux/BearSSL/conf/KalrayCompCert.mk index 9b34eed2..d67fdb8b 100644 --- a/test/monniaux/BearSSL/conf/KalrayCompCert.mk +++ b/test/monniaux/BearSSL/conf/KalrayCompCert.mk @@ -53,7 +53,7 @@ LDDLLOUT = -o # Static linker. LD = $(CC) -LDFLAGS = ../clock.gcc.k1c.o +LDFLAGS = ../clock.gcc.kvx.o LDOUT = -o # C# compiler; we assume usage of Mono. diff --git a/test/monniaux/Makefile b/test/monniaux/Makefile index d7437eea..3bceb4ab 100644 --- a/test/monniaux/Makefile +++ b/test/monniaux/Makefile @@ -14,8 +14,8 @@ verifier_times.txt: Asmblockdeps.patch oracle_times.txt: PostpassSchedulingOracle.patch (cd ../../ && make -j20 && make install) - patch $(realpath ../../mppa_k1c/PostpassSchedulingOracle.ml) < $< - (cd ../../ && make -j20 && make install); patch -R $(realpath ../../mppa_k1c/PostpassSchedulingOracle.ml) < $< + patch $(realpath ../../kvx/PostpassSchedulingOracle.ml) < $< + (cd ../../ && make -j20 && make install); patch -R $(realpath ../../kvx/PostpassSchedulingOracle.ml) < $< bash clean_benches.sh bash build_benches.sh $@ @@ -30,10 +30,10 @@ measures.csv: #compile_times.pdf: gencompile.py verifier_times.txt oracle_times.txt # python3.5 $^ $@ # -#measure_times.k1c.pdf: gengraphs.py measures.csv +#measure_times.kvx.pdf: gengraphs.py measures.csv # python3.5 $^ $(basename $(basename $@)) .PHONY: clean: @bash clean_benches.sh - rm -f verifier_times.txt oracle_times.txt compile_times.pdf measure_times.k1c.pdf measures.csv + rm -f verifier_times.txt oracle_times.txt compile_times.pdf measure_times.kvx.pdf measures.csv diff --git a/test/monniaux/PostpassSchedulingOracle.patch b/test/monniaux/PostpassSchedulingOracle.patch index 31afdbc8..11a36c1b 100644 --- a/test/monniaux/PostpassSchedulingOracle.patch +++ b/test/monniaux/PostpassSchedulingOracle.patch @@ -1,7 +1,7 @@ -diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml +diff --git a/kvx/PostpassSchedulingOracle.ml b/kvx/PostpassSchedulingOracle.ml index 2fc561e..d3748e8 100644 ---- a/mppa_k1c/PostpassSchedulingOracle.ml -+++ b/mppa_k1c/PostpassSchedulingOracle.ml +--- a/kvx/PostpassSchedulingOracle.ml ++++ b/kvx/PostpassSchedulingOracle.ml @@ -808,7 +808,7 @@ let print_bb oc bb = let asm_instructions = Asm.unfold_bblock bb in List.iter (print_inst oc) asm_instructions diff --git a/test/monniaux/README.md b/test/monniaux/README.md index 14b062da..c4978465 100644 --- a/test/monniaux/README.md +++ b/test/monniaux/README.md @@ -33,8 +33,8 @@ prints something of the form `c3 cycles: 44131`. - `ALL_CFLAGS`: `cflags` that are to be included for all compilers - `ALL_GCCFLAGS`: same, but GCC specific - `ALL_CCOMPFLAGS`: same, but `ccomp` specific -- `K1C_CC`: GCC compiler (default `k1-cos-gcc`) -- `K1C_CCOMP`: `CompCert` compiler (default `ccomp`) +- `KVX_CC`: GCC compiler (default `k1-cos-gcc`) +- `KVX_CCOMP`: `CompCert` compiler (default `ccomp`) - `EXECUTE_CYCLES`: running command (default is `k1-cluster --syscall=libstd_scalls.so --cycle-based --`) - `EXECUTE_ARGS`: execution arguments. You can use a macro `__BASE__` which expands to the name of the binary being executed. - `GCCiFLAGS` with `i` from 0 to 4: the wanted optimizations. If one of these flags is empty, nothing is done. Same for `CCOMPiFLAGS`. Look at `rules.mk` to see the default values. You might find something like this: diff --git a/test/monniaux/acswap/test_swapd.c b/test/monniaux/acswap/test_swapd.c index 4841f040..02dd8b06 100644 --- a/test/monniaux/acswap/test_swapd.c +++ b/test/monniaux/acswap/test_swapd.c @@ -8,6 +8,6 @@ int main() { unsigned long low, high; } i64_2; } ret; - ret.i128 = __builtin_k1_acswapd(&loc, next, current); + ret.i128 = __builtin_kvx_acswapd(&loc, next, current); printf("%lx %lx\n", ret.i64_2.low, ret.i64_2.high); } diff --git a/test/monniaux/acswap/test_swapw.c b/test/monniaux/acswap/test_swapw.c index 906938e0..6fb7d1cd 100644 --- a/test/monniaux/acswap/test_swapw.c +++ b/test/monniaux/acswap/test_swapw.c @@ -8,6 +8,6 @@ int main() { unsigned long low, high; } i64_2; } ret; - ret.i128 = __builtin_k1_acswapw(&loc, next, current); + ret.i128 = __builtin_kvx_acswapw(&loc, next, current); printf("%lx %lx\n", ret.i64_2.low, ret.i64_2.high); } diff --git a/test/monniaux/bitsliced-aes/notes.org b/test/monniaux/bitsliced-aes/notes.org index 6c2e27fa..c9a6fea2 100644 --- a/test/monniaux/bitsliced-aes/notes.org +++ b/test/monniaux/bitsliced-aes/notes.org @@ -3,52 +3,52 @@ ==> test.ccomp.host.out <== cycles: 3080223 -==> test.ccomp.k1c.out <== +==> test.ccomp.kvx.out <== cycles: 10145951 ==> test.gcc.host.out <== cycles: 1485887 -==> test.gcc.k1c.out <== +==> test.gcc.kvx.out <== cycles: 4078535 ** neg and ==> test.ccomp.host.out <== cycles: 2905049 -==> test.ccomp.k1c.out <== +==> test.ccomp.kvx.out <== cycles: 7995063 ==> test.gcc.host.out <== cycles: 1858263 -==> test.gcc.k1c.out <== +==> test.gcc.kvx.out <== cycles: 5255763 ** cmove mais mauvais scheduling de registres ==> test.ccomp.host.out <== cycles: 4363682 -==> test.ccomp.k1c.out <== +==> test.ccomp.kvx.out <== cycles: 7208629 ==> test.gcc.host.out <== cycles: 2916854 -==> test.gcc.k1c.out <== +==> test.gcc.kvx.out <== cycles: 5646730 ** cmove via match du and ==> test.ccomp.host.out <== cycles: 2553732 -==> test.ccomp.k1c.out <== +==> test.ccomp.kvx.out <== cycles: 7208629 ==> test.gcc.host.out <== cycles: 1849125 -==> test.gcc.k1c.out <== +==> test.gcc.kvx.out <== cycles: 5255763 ** hand optimized loads diff --git a/test/monniaux/bitsliced-aes/one_file/compare.sh b/test/monniaux/bitsliced-aes/one_file/compare.sh index e069eef6..314c1718 100755 --- a/test/monniaux/bitsliced-aes/one_file/compare.sh +++ b/test/monniaux/bitsliced-aes/one_file/compare.sh @@ -1,12 +1,12 @@ #!/bin/bash ROOT=/home/monniaux/work/Kalray/CompCert SRC=bitsliced-aes.c -k1-cos-gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.k1c.o -o bitsliced-aes.gcc.k1c && -$ROOT/ccomp -O3 -fno-unprototyped -O3 $SRC $ROOT/test/monniaux/clock.gcc.k1c.o -o bitsliced-aes.ccomp.k1c && +k1-cos-gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.kvx.o -o bitsliced-aes.gcc.kvx && +$ROOT/ccomp -O3 -fno-unprototyped -O3 $SRC $ROOT/test/monniaux/clock.gcc.kvx.o -o bitsliced-aes.ccomp.kvx && gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.host.o -o bitsliced-aes.gcc.host && valgrind ./bitsliced-aes.gcc.host && -k1-cluster -- ./bitsliced-aes.gcc.k1c > ./bitsliced-aes.gcc.k1c.out && -k1-cluster -- ./bitsliced-aes.ccomp.k1c > ./bitsliced-aes.ccomp.k1c.out && -grep cycles ./bitsliced-aes.gcc.k1c.out | sed -e 's/cycles: //' > ./bitsliced-aes.gcc.k1c.cycles && -grep cycles ./bitsliced-aes.ccomp.k1c.out | sed -e 's/cycles: //' > ./bitsliced-aes.ccomp.k1c.cycles && -test $(cat ./bitsliced-aes.ccomp.k1c.cycles) -gt $(expr 2 '*' $(cat ./bitsliced-aes.gcc.k1c.cycles)) +k1-cluster -- ./bitsliced-aes.gcc.kvx > ./bitsliced-aes.gcc.kvx.out && +k1-cluster -- ./bitsliced-aes.ccomp.kvx > ./bitsliced-aes.ccomp.kvx.out && +grep cycles ./bitsliced-aes.gcc.kvx.out | sed -e 's/cycles: //' > ./bitsliced-aes.gcc.kvx.cycles && +grep cycles ./bitsliced-aes.ccomp.kvx.out | sed -e 's/cycles: //' > ./bitsliced-aes.ccomp.kvx.cycles && +test $(cat ./bitsliced-aes.ccomp.kvx.cycles) -gt $(expr 2 '*' $(cat ./bitsliced-aes.gcc.kvx.cycles)) diff --git a/test/monniaux/bitsliced-aes/one_file/reduce/compare.sh b/test/monniaux/bitsliced-aes/one_file/reduce/compare.sh index 97939771..0f61ad00 100755 --- a/test/monniaux/bitsliced-aes/one_file/reduce/compare.sh +++ b/test/monniaux/bitsliced-aes/one_file/reduce/compare.sh @@ -2,15 +2,15 @@ ROOT=/home/monniaux/work/Kalray/CompCert SRC=bitsliced-aes_compute.c MAIN=/home/monniaux/work/Kalray/CompCert/test/monniaux/bitsliced-aes/one_file/reduce/bitsliced-aes_main -k1-cos-gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.k1c.o $MAIN.gcc.k1c.o -o bitsliced-aes.gcc.k1c && -$ROOT/ccomp -O3 -fno-unprototyped -O3 $SRC $ROOT/test/monniaux/clock.gcc.k1c.o $MAIN.gcc.k1c.o -o bitsliced-aes.ccomp.k1c && +k1-cos-gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.kvx.o $MAIN.gcc.kvx.o -o bitsliced-aes.gcc.kvx && +$ROOT/ccomp -O3 -fno-unprototyped -O3 $SRC $ROOT/test/monniaux/clock.gcc.kvx.o $MAIN.gcc.kvx.o -o bitsliced-aes.ccomp.kvx && gcc -Werror=implicit -Werror=uninitialized -O3 $SRC $ROOT/test/monniaux/clock.gcc.host.o $MAIN.c -o bitsliced-aes.gcc.host && valgrind ./bitsliced-aes.gcc.host && -k1-cluster --cycle-based -- ./bitsliced-aes.gcc.k1c > ./bitsliced-aes.gcc.k1c.out && -k1-cluster --cycle-based -- ./bitsliced-aes.ccomp.k1c > ./bitsliced-aes.ccomp.k1c.out && -grep cycles ./bitsliced-aes.gcc.k1c.out > ./bitsliced-aes.gcc.k1c.cycles && -grep cycles ./bitsliced-aes.ccomp.k1c.out > ./bitsliced-aes.ccomp.k1c.cycles && -sed -i -e 's/cycles: //' ./bitsliced-aes.gcc.k1c.cycles && -sed -i -e 's/cycles: //' ./bitsliced-aes.ccomp.k1c.cycles && -test $(cat ./bitsliced-aes.gcc.k1c.cycles) -gt 100000 && -test $(cat ./bitsliced-aes.ccomp.k1c.cycles) -gt $(expr 2 '*' $(cat ./bitsliced-aes.gcc.k1c.cycles)) +k1-cluster --cycle-based -- ./bitsliced-aes.gcc.kvx > ./bitsliced-aes.gcc.kvx.out && +k1-cluster --cycle-based -- ./bitsliced-aes.ccomp.kvx > ./bitsliced-aes.ccomp.kvx.out && +grep cycles ./bitsliced-aes.gcc.kvx.out > ./bitsliced-aes.gcc.kvx.cycles && +grep cycles ./bitsliced-aes.ccomp.kvx.out > ./bitsliced-aes.ccomp.kvx.cycles && +sed -i -e 's/cycles: //' ./bitsliced-aes.gcc.kvx.cycles && +sed -i -e 's/cycles: //' ./bitsliced-aes.ccomp.kvx.cycles && +test $(cat ./bitsliced-aes.gcc.kvx.cycles) -gt 100000 && +test $(cat ./bitsliced-aes.ccomp.kvx.cycles) -gt $(expr 2 '*' $(cat ./bitsliced-aes.gcc.kvx.cycles)) diff --git a/test/monniaux/bitsliced-tea/bstea_wordsize.h b/test/monniaux/bitsliced-tea/bstea_wordsize.h index b4e2e823..4305db58 100644 --- a/test/monniaux/bitsliced-tea/bstea_wordsize.h +++ b/test/monniaux/bitsliced-tea/bstea_wordsize.h @@ -6,7 +6,7 @@ #if defined __x86_64__ || defined __amd64__ || defined __x86_64 || \ defined __amd64 || defined _M_X64 || defined __ia64__ || \ defined __ia64__ || defined __IA64__ || defined __ia64 || \ - defined _M_IA64 || defined __K1C__ + defined _M_IA64 || defined __KVX__ # define __BSTEA_WORDSIZE 64 #else # define __BSTEA_WORDSIZE 32 diff --git a/test/monniaux/bitsliced-tea/reduce/compare.sh b/test/monniaux/bitsliced-tea/reduce/compare.sh index f0b1f8d2..7f96491b 100755 --- a/test/monniaux/bitsliced-tea/reduce/compare.sh +++ b/test/monniaux/bitsliced-tea/reduce/compare.sh @@ -5,16 +5,16 @@ GCC_K1="k1-cos-gcc -Werror=implicit -O3 $INCLUDES" GCC_HOST="gcc -Werror=implicit -O3 $INCLUDES" FILE=bstea.c -OTHERS_K1="$PREFIX/test/monniaux/bitsliced-tea/bstea_run.gcc.k1c.o $PREFIX/test/monniaux/clock.gcc.k1c.o" +OTHERS_K1="$PREFIX/test/monniaux/bitsliced-tea/bstea_run.gcc.kvx.o $PREFIX/test/monniaux/clock.gcc.kvx.o" OTHERS_HOST="$PREFIX/test/monniaux/bitsliced-tea/bstea_run.gcc.host.o $PREFIX/test/monniaux/clock.gcc.host.o" -$CCOMP_K1 $FILE $OTHERS_K1 -o bstead.ccomp.k1c && -$GCC_K1 $FILE $OTHERS_K1 -o bstead.gcc.k1c && +$CCOMP_K1 $FILE $OTHERS_K1 -o bstead.ccomp.kvx && +$GCC_K1 $FILE $OTHERS_K1 -o bstead.gcc.kvx && $GCC_HOST $FILE $OTHERS_HOST -o bstead.gcc.host && valgrind -q ./bstead.gcc.host && -k1-cluster --cycle-based -- bstead.ccomp.k1c > bstead.ccomp.k1c.out && -k1-cluster --cycle-based -- bstead.gcc.k1c > bstead.gcc.k1c.out && -grep cycles bstead.ccomp.k1c.out|sed -e 's/cycles: //' > bstead.ccomp.k1c.cycles && -grep cycles bstead.gcc.k1c.out|sed -e 's/cycles: //' > bstead.gcc.k1c.cycles && -test `cat bstead.gcc.k1c.cycles` -gt 100000 && -test `cat bstead.ccomp.k1c.cycles` -gt 200000 +k1-cluster --cycle-based -- bstead.ccomp.kvx > bstead.ccomp.kvx.out && +k1-cluster --cycle-based -- bstead.gcc.kvx > bstead.gcc.kvx.out && +grep cycles bstead.ccomp.kvx.out|sed -e 's/cycles: //' > bstead.ccomp.kvx.cycles && +grep cycles bstead.gcc.kvx.out|sed -e 's/cycles: //' > bstead.gcc.kvx.cycles && +test `cat bstead.gcc.kvx.cycles` -gt 100000 && +test `cat bstead.ccomp.kvx.cycles` -gt 200000 diff --git a/test/monniaux/crypto-algorithms/Makefile b/test/monniaux/crypto-algorithms/Makefile index 41daba38..fde22f38 100644 --- a/test/monniaux/crypto-algorithms/Makefile +++ b/test/monniaux/crypto-algorithms/Makefile @@ -1,28 +1,28 @@ include ../rules.mk all: md2.all md5.all sha1.all sha256.all blowfish.all des.all -k1c: md2_test.ccomp.k1c md5_test.ccomp.k1c sha1_test.ccomp.k1c sha256_test.ccomp.k1c blowfish_test.ccomp.k1c des_test.ccomp.k1c +kvx: md2_test.ccomp.kvx md5_test.ccomp.kvx sha1_test.ccomp.kvx sha256_test.ccomp.kvx blowfish_test.ccomp.kvx des_test.ccomp.kvx -md2.all : md2_test.ccomp.k1c.out md2_test.gcc.k1c.out -md5.all : md5_test.ccomp.k1c.out md5_test.gcc.k1c.out -arcfour.all : arcfour_test.ccomp.k1c.out arcfour_test.gcc.k1c.out -blowfish.all : blowfish_test.ccomp.k1c.out blowfish_test.gcc.k1c.out -rot-13.all : rot-13_test.ccomp.k1c.out rot-13_test.gcc.k1c.out -sha1.all : sha1_test.ccomp.k1c.out sha1_test.gcc.k1c.out -sha256.all : sha256_test.ccomp.k1c.out sha256_test.gcc.k1c.out -des.all: des_test.ccomp.k1c.out des_test.gcc.k1c.out -base64.all: base64_test.ccomp.k1c.out base64_test.gcc.k1c.out -aes.all : aes_test.ccomp.k1c.out aes_test.gcc.k1c.out +md2.all : md2_test.ccomp.kvx.out md2_test.gcc.kvx.out +md5.all : md5_test.ccomp.kvx.out md5_test.gcc.kvx.out +arcfour.all : arcfour_test.ccomp.kvx.out arcfour_test.gcc.kvx.out +blowfish.all : blowfish_test.ccomp.kvx.out blowfish_test.gcc.kvx.out +rot-13.all : rot-13_test.ccomp.kvx.out rot-13_test.gcc.kvx.out +sha1.all : sha1_test.ccomp.kvx.out sha1_test.gcc.kvx.out +sha256.all : sha256_test.ccomp.kvx.out sha256_test.gcc.kvx.out +des.all: des_test.ccomp.kvx.out des_test.gcc.kvx.out +base64.all: base64_test.ccomp.kvx.out base64_test.gcc.kvx.out +aes.all : aes_test.ccomp.kvx.out aes_test.gcc.kvx.out -%.gcc.k1c.s %.ccomp.k1c.s %_test.gcc.k1c.s: %.h +%.gcc.kvx.s %.ccomp.kvx.s %_test.gcc.kvx.s: %.h -%_test.gcc.k1c: %.gcc.k1c.o %_test.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ +%_test.gcc.kvx: %.gcc.kvx.o %_test.gcc.kvx.o + $(KVX_CC) $(KVX_CFLAGS) $+ -o $@ -%_test.ccomp.k1c: %.ccomp.k1c.o %_test.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +%_test.ccomp.kvx: %.ccomp.kvx.o %_test.gcc.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ clean: - $(RM) -f *.s *.o *.out *.k1c *.host + $(RM) -f *.s *.o *.out *.kvx *.host .PHONY: clean all md2.all md5.all rot-13.all sha1.all sha256.all md5.all blowfish.all arcfour.all des.all base64.all aes.all diff --git a/test/monniaux/csmith/Makefile b/test/monniaux/csmith/Makefile index 3c748c62..56313452 100644 --- a/test/monniaux/csmith/Makefile +++ b/test/monniaux/csmith/Makefile @@ -2,11 +2,11 @@ CSMITH?=/local/monniaux/packages/csmith-2.3.0/bin/csmith MAX=1000 include ../rules.mk -K1C_CCOMPFLAGS+=-I/local/monniaux/packages/csmith-2.3.0/include/csmith-2.3.0 -fstruct-passing -fbitfields +KVX_CCOMPFLAGS+=-I/local/monniaux/packages/csmith-2.3.0/include/csmith-2.3.0 -fstruct-passing -fbitfields -TARGETS_S=$(shell seq --format src%06.f.ccomp.k1c.s 0 $(MAX)) +TARGETS_S=$(shell seq --format src%06.f.ccomp.kvx.s 0 $(MAX)) TARGETS_C=$(shell seq --format src%06.f.c 0 $(MAX)) -TARGETS_O=$(shell seq --format src%06.f.ccomp.k1c.o 0 $(MAX)) +TARGETS_O=$(shell seq --format src%06.f.ccomp.kvx.o 0 $(MAX)) all: c s o diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h index 5011b18c..1f7a991a 100644 --- a/test/monniaux/cycles.h +++ b/test/monniaux/cycles.h @@ -2,7 +2,7 @@ #include #include -#ifdef __K1C__ +#ifdef __KVX__ typedef uint64_t cycle_t; #define PRcycle PRId64 @@ -11,18 +11,18 @@ typedef uint64_t cycle_t; static inline void cycle_count_config(void) { /* config pmc for cycle count */ - cycle_t pmc_value = __builtin_k1_get(COS_SFR_PMC); + cycle_t pmc_value = __builtin_kvx_get(COS_SFR_PMC); pmc_value &= ~(0xfULL); - __builtin_k1_set(COS_SFR_PMC, pmc_value); + __builtin_kvx_set(COS_SFR_PMC, pmc_value); } static inline cycle_t get_cycle(void) { - return __builtin_k1_get(COS_SFR_PM0); + return __builtin_kvx_get(COS_SFR_PM0); } -#else // not K1C +#else // not KVX static inline void cycle_count_config(void) { } #if defined(__i386__) || defined( __x86_64__) diff --git a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified5 b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified5 index 9263169b..f56df84c 100644 --- a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified5 +++ b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified5 @@ -1,5 +1,5 @@ # File generated by CompCert 3.4 -# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.k1c.s +# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.kvx.s .text .balign 2 downheap: diff --git a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified7 b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified7 index 4d6a12de..0c873f0e 100644 --- a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified7 +++ b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.modified7 @@ -1,5 +1,5 @@ # File generated by CompCert 3.4 -# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.k1c.s +# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.kvx.s .text .balign 2 downheap: diff --git a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.orig b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.orig index 3dc370b8..0d7d5c0b 100644 --- a/test/monniaux/heapsort/heapsort.ccomp.k1c.s.orig +++ b/test/monniaux/heapsort/heapsort.ccomp.k1c.s.orig @@ -1,5 +1,5 @@ # File generated by CompCert 3.4 -# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.k1c.s +# Command line: -Wall -O3 -S heapsort.c -o heapsort.ccomp.kvx.s .text .balign 2 downheap: diff --git a/test/monniaux/jpeg-6b/Makefile b/test/monniaux/jpeg-6b/Makefile index 2bec9bb7..36d230a1 100644 --- a/test/monniaux/jpeg-6b/Makefile +++ b/test/monniaux/jpeg-6b/Makefile @@ -15,7 +15,7 @@ EXECUTE_ARGS=-dct int -outfile __BASE__.jpg testimg.ppm 2> __BASE__.out include ../rules.mk -#all: cjpeg.gcc.k1c.out djpeg.gcc.k1c.out cjpeg.gcc.o1.k1c.out djpeg.gcc.o1.k1c.out cjpeg.ccomp.k1c.out djpeg.ccomp.k1c.out +#all: cjpeg.gcc.kvx.out djpeg.gcc.kvx.out cjpeg.gcc.o1.kvx.out djpeg.gcc.o1.kvx.out cjpeg.ccomp.kvx.out djpeg.ccomp.kvx.out # #LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \ # jcinit.c jcmainct.c jcmarker.c jcmaster.c jcomapi.c jcparam.c \ @@ -27,26 +27,26 @@ include ../rules.mk # jquant2.c jutils.c jmemmgr.c jmemansi.c #CSOURCES=$(LIBSOURCES) rdppm.c rdgif.c rdtarga.c rdrle.c rdbmp.c rdswitch.c cdjpeg.c wrppm.c wrgif.c wrtarga.c wrrle.c wrbmp.c rdcolmap.c # -#LIB_K1C_GCC_OFILES=$(CSOURCES:.c=.gcc.k1c.o) -#LIB_K1C_GCC_O1_OFILES=$(CSOURCES:.c=.gcc.o1.k1c.o) -#LIB_K1C_CCOMP_OFILES=$(CSOURCES:.c=.ccomp.k1c.o) +#LIB_KVX_GCC_OFILES=$(CSOURCES:.c=.gcc.kvx.o) +#LIB_KVX_GCC_O1_OFILES=$(CSOURCES:.c=.gcc.o1.kvx.o) +#LIB_KVX_CCOMP_OFILES=$(CSOURCES:.c=.ccomp.kvx.o) # #include ../rules.mk # -#cjpeg.gcc.k1c: $(LIB_K1C_GCC_OFILES) cjpeg.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ ../clock.gcc.k1c.o -#djpeg.gcc.k1c: $(LIB_K1C_GCC_OFILES) djpeg.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ ../clock.gcc.k1c.o +#cjpeg.gcc.kvx: $(LIB_KVX_GCC_OFILES) cjpeg.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS) -o $@ $+ ../clock.gcc.kvx.o +#djpeg.gcc.kvx: $(LIB_KVX_GCC_OFILES) djpeg.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS) -o $@ $+ ../clock.gcc.kvx.o # -#cjpeg.gcc.o1.k1c: $(LIB_K1C_GCC_O1_OFILES) cjpeg.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ ../clock.gcc.k1c.o -#djpeg.gcc.o1.k1c: $(LIB_K1C_GCC_O1_OFILES) djpeg.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ ../clock.gcc.k1c.o +#cjpeg.gcc.o1.kvx: $(LIB_KVX_GCC_O1_OFILES) cjpeg.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS_O1) -o $@ $+ ../clock.gcc.kvx.o +#djpeg.gcc.o1.kvx: $(LIB_KVX_GCC_O1_OFILES) djpeg.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS_O1) -o $@ $+ ../clock.gcc.kvx.o # -#cjpeg.ccomp.k1c: $(LIB_K1C_CCOMP_OFILES) cjpeg.gcc.k1c.o -# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ ../clock.gcc.k1c.o -#djpeg.ccomp.k1c: $(LIB_K1C_CCOMP_OFILES) djpeg.gcc.k1c.o -# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ ../clock.gcc.k1c.o +#cjpeg.ccomp.kvx: $(LIB_KVX_CCOMP_OFILES) cjpeg.gcc.kvx.o +# $(KVX_CCOMP) $(KVX_CCOMPFLAGS) -o $@ $+ ../clock.gcc.kvx.o +#djpeg.ccomp.kvx: $(LIB_KVX_CCOMP_OFILES) djpeg.gcc.kvx.o +# $(KVX_CCOMP) $(KVX_CCOMPFLAGS) -o $@ $+ ../clock.gcc.kvx.o # # #djpeg.%.out: djpeg.% diff --git a/test/monniaux/k1_builtins/atomics.c b/test/monniaux/k1_builtins/atomics.c index 40c459e2..481a4aee 100644 --- a/test/monniaux/k1_builtins/atomics.c +++ b/test/monniaux/k1_builtins/atomics.c @@ -2,10 +2,10 @@ int main() { long lval = 45; - long lval2 = __builtin_k1_afaddd(&lval, 6); + long lval2 = __builtin_kvx_afaddd(&lval, 6); printf("%ld %ld\n", lval, lval2); int ival = 45; - int ival2 = __builtin_k1_afaddw(&ival, 6); + int ival2 = __builtin_kvx_afaddw(&ival, 6); printf("%d %d\n", ival, ival2); return 0; } diff --git a/test/monniaux/k1_builtins/execute_code.c b/test/monniaux/k1_builtins/execute_code.c index 58580ed9..d3cc35d2 100644 --- a/test/monniaux/k1_builtins/execute_code.c +++ b/test/monniaux/k1_builtins/execute_code.c @@ -19,7 +19,7 @@ int main() { int rpoulet = (*((fun_type*) buf))(33); memcpy(buf, canard, SIZE); int rcanard = (*((fun_type*) buf))(33); - __builtin_k1_iinval(); + __builtin_kvx_iinval(); int rcanard2 = (*((fun_type*) buf))(33); free(buf); printf("%d %d %d\n", rpoulet, rcanard, rcanard2); diff --git a/test/monniaux/k1_builtins/sbmm8.c b/test/monniaux/k1_builtins/sbmm8.c index 3b2ac447..dba7a72b 100644 --- a/test/monniaux/k1_builtins/sbmm8.c +++ b/test/monniaux/k1_builtins/sbmm8.c @@ -3,12 +3,12 @@ int main() { { unsigned long a = 0x12345678ABCDEFUL, b=0x12345118ABCD32UL, c; - c = __builtin_k1_sbmm8(a, b); + c = __builtin_kvx_sbmm8(a, b); printf("%lx\n", c); } { unsigned long a = 0x0102040810204080UL, b=0x12345118ABCD32UL, c; - c = __builtin_k1_sbmm8(a, b); + c = __builtin_kvx_sbmm8(a, b); printf("%lx\n", c); } return 0; diff --git a/test/monniaux/k1_builtins/test_k1_builtins.c b/test/monniaux/k1_builtins/test_k1_builtins.c index e02c7f2e..29903bb6 100644 --- a/test/monniaux/k1_builtins/test_k1_builtins.c +++ b/test/monniaux/k1_builtins/test_k1_builtins.c @@ -1,40 +1,40 @@ #include -#include +#include void test_system_regs(void) { - __builtin_k1_wfxl(K1_SFR_EV4, 0x1000ULL); - __builtin_k1_wfxm(K1_SFR_EV4, 0x2000ULL); - __builtin_k1_get(K1_SFR_EV4); - __builtin_k1_set(K1_SFR_EV4, 0x4000ULL); + __builtin_kvx_wfxl(K1_SFR_EV4, 0x1000ULL); + __builtin_kvx_wfxm(K1_SFR_EV4, 0x2000ULL); + __builtin_kvx_get(K1_SFR_EV4); + __builtin_kvx_set(K1_SFR_EV4, 0x4000ULL); } void test_loads(void *addr) { - __builtin_k1_alclrd(addr); - __builtin_k1_alclrw(addr); - __builtin_k1_lbzu(addr); - __builtin_k1_lhzu(addr); - __builtin_k1_lwzu(addr); - __builtin_k1_ldu(addr); - __builtin_k1_dinvall(addr); - __builtin_k1_dtouchl(addr); - __builtin_k1_dzerol(addr); - __builtin_k1_iinvals(addr); - /* __builtin_k1_itouchl(addr); */ - __builtin_k1_dzerol(addr); + __builtin_kvx_alclrd(addr); + __builtin_kvx_alclrw(addr); + __builtin_kvx_lbzu(addr); + __builtin_kvx_lhzu(addr); + __builtin_kvx_lwzu(addr); + __builtin_kvx_ldu(addr); + __builtin_kvx_dinvall(addr); + __builtin_kvx_dtouchl(addr); + __builtin_kvx_dzerol(addr); + __builtin_kvx_iinvals(addr); + /* __builtin_kvx_itouchl(addr); */ + __builtin_kvx_dzerol(addr); } void test_stops(void) { - __builtin_k1_await(); - __builtin_k1_sleep(); - __builtin_k1_stop(); - __builtin_k1_barrier(); - __builtin_k1_fence(); - __builtin_k1_dinval(); - __builtin_k1_iinval(); + __builtin_kvx_await(); + __builtin_kvx_sleep(); + __builtin_kvx_stop(); + __builtin_kvx_barrier(); + __builtin_kvx_fence(); + __builtin_kvx_dinval(); + __builtin_kvx_iinval(); } int main() { unsigned long long data = 45; - unsigned long long res = __builtin_k1_alclrd(&data); + unsigned long long res = __builtin_kvx_alclrd(&data); printf("%llu %llu\n", res, data); } diff --git a/test/monniaux/math/exceptions.c b/test/monniaux/math/exceptions.c index 72107066..84ed54db 100644 --- a/test/monniaux/math/exceptions.c +++ b/test/monniaux/math/exceptions.c @@ -4,16 +4,16 @@ #pragma STDC FENV_ACCESS ON -#if defined(__K1C__) && !defined(__COMPCERT__) +#if defined(__KVX__) && !defined(__COMPCERT__) int fetestexcept(int excepts) { int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts; - unsigned long long cs = __builtin_k1_get(K1_SFR_CS); + unsigned long long cs = __builtin_kvx_get(K1_SFR_CS); return cs & mask; } int feclearexcept(int excepts) { int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts; - __builtin_k1_wfxl(K1_SFR_CS, mask); + __builtin_kvx_wfxl(K1_SFR_CS, mask); return 0; } #endif diff --git a/test/monniaux/math/rounding.c b/test/monniaux/math/rounding.c index c2ce85e3..3ac8faf0 100644 --- a/test/monniaux/math/rounding.c +++ b/test/monniaux/math/rounding.c @@ -1,18 +1,18 @@ #include #include -#ifdef __K1C__ -#include +#ifdef __KVX__ +#include int fesetround(int rounding_mode) { if (rounding_mode < 0 || rounding_mode > 3) return 1; - unsigned long long cs = __builtin_k1_get(K1_SFR_CS); + unsigned long long cs = __builtin_kvx_get(K1_SFR_CS); cs = (cs & ~(3 << 16)) | (rounding_mode << 16); - __builtin_k1_set(K1_SFR_CS, cs); + __builtin_kvx_set(K1_SFR_CS, cs); return 0; } int fegetround(void) { - unsigned long long cs = __builtin_k1_get(K1_SFR_CS); + unsigned long long cs = __builtin_kvx_get(K1_SFR_CS); return (cs >> 16) & 3; } #endif diff --git a/test/monniaux/micro-bunzip/Makefile b/test/monniaux/micro-bunzip/Makefile index 58dfed9b..bfcc377a 100644 --- a/test/monniaux/micro-bunzip/Makefile +++ b/test/monniaux/micro-bunzip/Makefile @@ -1,24 +1,24 @@ include ../rules.mk -all: testfile.txt testfile.txt.2ccomp testfile.txt.2gcc testfile.ccomp.k1c.out testfile.gcc.k1c.out testfile.ccomp.host.out testfile.gcc.host.out +all: testfile.txt testfile.txt.2ccomp testfile.txt.2gcc testfile.ccomp.kvx.out testfile.gcc.kvx.out testfile.ccomp.host.out testfile.gcc.host.out cmp testfile.txt testfile.txt.2ccomp cmp testfile.txt testfile.txt.2gcc micro-bunzip.ccomp.host: micro-bunzip.c ../clock.gcc.host.o $(CCOMP) $(CCOMPFLAGS) $+ -o $@ -micro-bunzip.ccomp.k1c: micro-bunzip.c ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +micro-bunzip.ccomp.kvx: micro-bunzip.c ../clock.gcc.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ micro-bunzip.gcc.host: micro-bunzip.c ../clock.gcc.host.o $(CC) $(CFLAGS) $+ -o $@ -# micro-bunzip.gcc.k1c: micro-bunzip.c ../clock.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ +# micro-bunzip.gcc.kvx: micro-bunzip.c ../clock.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS) $+ -o $@ # TODO: -O3 buggy?? -micro-bunzip.gcc.k1c: micro-bunzip.c ../clock.gcc.k1c.o - $(K1C_CC) -Wall -O2 $+ -o $@ +micro-bunzip.gcc.kvx: micro-bunzip.c ../clock.gcc.kvx.o + $(KVX_CC) -Wall -O2 $+ -o $@ testfile.txt: micro-bunzip.c cat micro-bunzip.c > $@ @@ -35,11 +35,11 @@ testfile.txt: micro-bunzip.c # sha512sum micro-bunzip.c >> $@ #x cat micro-bunzip.c >> $@ -testfile.txt.2ccomp testfile.ccomp.k1c.out: testfile.txt micro-bunzip.ccomp.k1c - bzip2 testfile.txt.2ccomp 2> testfile.ccomp.k1c.out +testfile.txt.2ccomp testfile.ccomp.kvx.out: testfile.txt micro-bunzip.ccomp.kvx + bzip2 testfile.txt.2ccomp 2> testfile.ccomp.kvx.out -testfile.txt.2gcc testfile.gcc.k1c.out: testfile.txt micro-bunzip.gcc.k1c - bzip2 testfile.txt.2gcc 2> testfile.gcc.k1c.out +testfile.txt.2gcc testfile.gcc.kvx.out: testfile.txt micro-bunzip.gcc.kvx + bzip2 testfile.txt.2gcc 2> testfile.gcc.kvx.out testfile.txt.2host testfile.gcc.host.out: testfile.txt micro-bunzip.gcc.host bzip2 testfile.txt.2host 2> testfile.gcc.host.out @@ -48,6 +48,6 @@ testfile.ccomp.host.out: testfile.txt micro-bunzip.ccomp.host bzip2 /dev/null 2> testfile.ccomp.host.out clean: - rm -f *.k1c *.out test*txt* + rm -f *.kvx *.out test*txt* .PHONY: clean diff --git a/test/monniaux/minisat/Makefile b/test/monniaux/minisat/Makefile index f98b69b7..3a0268a6 100644 --- a/test/monniaux/minisat/Makefile +++ b/test/monniaux/minisat/Makefile @@ -5,7 +5,7 @@ EXECUTE_ARGS=sudoku.sat src=main.c solver.c -PRODUCTS?=minisat.gcc.host minisat.ccomp.host minisat.gcc.k1c minisat.gcc.o1.k1c minisat.ccomp.k1c +PRODUCTS?=minisat.gcc.host minisat.ccomp.host minisat.gcc.kvx minisat.gcc.o1.kvx minisat.ccomp.kvx PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) all: $(PRODUCTS) @@ -19,18 +19,18 @@ minisat.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o $(CC) $(CFLAGS) $+ $(LIBS) -o $@ minisat.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o $(CCOMP) $(CCOMPFLAGS) $+ $(LIBS) -o $@ -minisat.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ $(LIBS) -o $@ -minisat.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS_O1) $+ $(LIBS) -o $@ -minisat.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ $(LIBS) -o $@ +minisat.gcc.kvx: $(src:.c=.gcc.kvx.o) ../clock.gcc.kvx.o + $(KVX_CC) $(KVX_CFLAGS) $+ $(LIBS) -o $@ +minisat.gcc.o1.kvx: $(src:.c=.gcc.o1.kvx.o) ../clock.gcc.kvx.o + $(KVX_CC) $(KVX_CFLAGS_O1) $+ $(LIBS) -o $@ +minisat.ccomp.kvx: $(src:.c=.ccomp.kvx.o) ../clock.gcc.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ $(LIBS) -o $@ measures.csv: $(PRODUCTS_OUT) - echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@ + echo "benches, gcc host,ccomp host,gcc kvx,gcc o1 kvx,ccomp kvx" > $@ .SECONDARY: .PHONY: clean: - rm -f *.o *.s *.k1c *.csv + rm -f *.o *.s *.kvx *.csv diff --git a/test/monniaux/mod_int_mat/Makefile b/test/monniaux/mod_int_mat/Makefile index 08b97b67..ff90f901 100644 --- a/test/monniaux/mod_int_mat/Makefile +++ b/test/monniaux/mod_int_mat/Makefile @@ -1,40 +1,40 @@ CFLAGS=-Wall -O3 -std=c99 -K1C_CC=k1-cos-gcc -K1C_CFLAGS=-Wall -O3 -std=c99 -K1C_CCOMP=../../../ccomp -K1C_CCOMPFLAGS=-Wall -O3 +KVX_CC=k1-cos-gcc +KVX_CFLAGS=-Wall -O3 -std=c99 +KVX_CCOMP=../../../ccomp +KVX_CCOMPFLAGS=-Wall -O3 -PRODUCTS=int_mat.host int_mat.gcc.k1c.out int_mat.ccomp.k1c.out int_mat.ccomp.k1c.s int_mat.gcc.k1c.s int_mat.gcc.k1c int_mat.ccomp.k1c +PRODUCTS=int_mat.host int_mat.gcc.kvx.out int_mat.ccomp.kvx.out int_mat.ccomp.kvx.s int_mat.gcc.kvx.s int_mat.gcc.kvx int_mat.ccomp.kvx all: $(PRODUCTS) -%.gcc.k1c.s: %.c - $(K1C_CC) $(K1C_CFLAGS) -S $< -o $@ +%.gcc.kvx.s: %.c + $(KVX_CC) $(KVX_CFLAGS) -S $< -o $@ -%.gcc.k1c.o: %.gcc.k1c.s - $(K1C_CC) $(K1C_CFLAGS) -c $< -o $@ +%.gcc.kvx.o: %.gcc.kvx.s + $(KVX_CC) $(KVX_CFLAGS) -c $< -o $@ -%.ccomp.k1c.s: %.c - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -S $< -o $@ +%.ccomp.kvx.s: %.c + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) -S $< -o $@ -%.ccomp.k1c.o: %.ccomp.k1c.s - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -c $< -o $@ +%.ccomp.kvx.o: %.ccomp.kvx.s + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) -c $< -o $@ int_mat.host: int_mat.c int_mat_run.c modint.h $(CC) $(CFLAGS) int_mat.c int_mat_run.c -o $@ -int_mat.gcc.k1c.s int_mat.ccomp.k1c.s int_mat_run.gcc.k1c.s: modint.h +int_mat.gcc.kvx.s int_mat.ccomp.kvx.s int_mat_run.gcc.kvx.s: modint.h -int_mat.gcc.k1c: int_mat.gcc.k1c.o int_mat_run.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ +int_mat.gcc.kvx: int_mat.gcc.kvx.o int_mat_run.gcc.kvx.o + $(KVX_CC) $(KVX_CFLAGS) $+ -o $@ -int_mat.ccomp.k1c: int_mat.ccomp.k1c.o int_mat_run.gcc.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +int_mat.ccomp.kvx: int_mat.ccomp.kvx.o int_mat_run.gcc.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ -%.k1c.out: %.k1c +%.kvx.out: %.kvx k1-cluster --cycle-based -- $< | tee $@ clean: - $(RM) -f $(PRODUCTS) int_mat.gcc.k1c.o int_mat.ccomp.k1c.o int_mat_run.gcc.k1c.o + $(RM) -f $(PRODUCTS) int_mat.gcc.kvx.o int_mat.ccomp.kvx.o int_mat_run.gcc.kvx.o .PHONY: clean diff --git a/test/monniaux/multithreaded_volatile/Makefile b/test/monniaux/multithreaded_volatile/Makefile index 35717953..6c7dd663 100644 --- a/test/monniaux/multithreaded_volatile/Makefile +++ b/test/monniaux/multithreaded_volatile/Makefile @@ -1,18 +1,18 @@ -all: volatile.ccomp.k1c volatile.gcc.k1c +all: volatile.ccomp.kvx volatile.gcc.kvx -volatile.ccomp.k1c : volatile.ccomp.k1c.s +volatile.ccomp.kvx : volatile.ccomp.kvx.s k1-cos-gcc $< -o $@ -volatile.gcc.k1c : volatile.gcc.k1c.s +volatile.gcc.kvx : volatile.gcc.kvx.s k1-cos-gcc $< -o $@ -volatile.ccomp.k1c.s : volatile.c +volatile.ccomp.kvx.s : volatile.c ../../../ccomp -O2 -Wall -S $< -o $@ -volatile.gcc.k1c.s : volatile.c +volatile.gcc.kvx.s : volatile.c k1-cos-gcc -O2 -Wall -Werror=implicit -std=gnu99 -S $< -o $@ clean: - -rm -f *.k1c *.s + -rm -f *.kvx *.s .PHONY: clean diff --git a/test/monniaux/ncompress/compress42.c b/test/monniaux/ncompress/compress42.c index 4a6c2f74..dd1efe3a 100644 --- a/test/monniaux/ncompress/compress42.c +++ b/test/monniaux/ncompress/compress42.c @@ -192,7 +192,7 @@ # define SIG_TYPE void (*)() #endif -#if defined(AMIGA) || defined(DOS) || defined(MINGW) || defined(WINDOWS) || defined(__K1C__) +#if defined(AMIGA) || defined(DOS) || defined(MINGW) || defined(WINDOWS) || defined(__KVX__) # define chmod(pathname, mode) 0 # define chown(pathname, owner, group) 0 # define utime(pathname, times) 0 diff --git a/test/monniaux/ocaml/byterun/toto b/test/monniaux/ocaml/byterun/toto index ac54a2b6..89897f38 100644 --- a/test/monniaux/ocaml/byterun/toto +++ b/test/monniaux/ocaml/byterun/toto @@ -741,11 +741,11 @@ 12429 mmap(NULL, 34607104, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0) = 0x7f4c61eff000 12429 mmap(NULL, 4294971392, PROT_READ|PROT_WRITE, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0) = 0x7f4b61efe000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 -12429 openat(AT_FDCWD, "/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", O_RDONLY|O_CLOEXEC) = 4 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 +12429 openat(AT_FDCWD, "/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", O_RDONLY|O_CLOEXEC) = 4 12429 read(4, "\177ELF\2\1\1\0\0\0\0\0\0\0\0\0\3\0>\0\1\0\0\0\260\214\2\0\0\0\0\0"..., 832) = 832 12429 fstat(4, {st_mode=S_IFREG|0755, st_size=1461464, ...}) = 0 12429 mmap(NULL, 3556520, PROT_READ|PROT_EXEC, MAP_PRIVATE|MAP_DENYWRITE, 4, 0) = 0x7f4c7038d000 @@ -810,10 +810,10 @@ 12429 mprotect(0x7f4c68f9d000, 4096, PROT_READ) = 0 12429 brk(0x3670000) = 0x3670000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -830,10 +830,10 @@ 12429 brk(0x3694000) = 0x3694000 12429 munmap(0x7f4c68719000, 6819840) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -849,10 +849,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -867,10 +867,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -884,10 +884,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -901,10 +901,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -918,10 +918,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -935,10 +935,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -952,10 +952,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -969,10 +969,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -986,10 +986,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1003,10 +1003,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1020,10 +1020,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1037,10 +1037,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1054,10 +1054,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1071,10 +1071,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1454,10 +1454,10 @@ 12429 brk(0x78fa000) = 0x78fa000 12429 brk(0x7921000) = 0x7921000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1473,10 +1473,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 brk(0x7fc2000) = 0x7fc2000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1491,10 +1491,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1509,10 +1509,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1526,10 +1526,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1543,10 +1543,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1560,10 +1560,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1577,10 +1577,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1594,10 +1594,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1611,10 +1611,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1628,10 +1628,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1645,10 +1645,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1662,10 +1662,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1679,10 +1679,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1696,10 +1696,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1713,10 +1713,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -1730,10 +1730,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2082,10 +2082,10 @@ 12429 brk(0xbdbc000) = 0xbdbc000 12429 brk(0xbddd000) = 0xbddd000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2101,10 +2101,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 brk(0xc4c7000) = 0xc4c7000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2119,10 +2119,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2137,10 +2137,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2154,10 +2154,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2171,10 +2171,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2188,10 +2188,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2205,10 +2205,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2222,10 +2222,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2239,10 +2239,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2256,10 +2256,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2273,10 +2273,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2290,10 +2290,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2307,10 +2307,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2324,10 +2324,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2341,10 +2341,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2358,10 +2358,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2710,10 +2710,10 @@ 12429 brk(0x102a5000) = 0x102a5000 12429 brk(0x102c6000) = 0x102c6000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2729,10 +2729,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 brk(0x10973000) = 0x10973000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2747,10 +2747,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2765,10 +2765,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2782,10 +2782,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2799,10 +2799,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2816,10 +2816,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2833,10 +2833,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2850,10 +2850,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2867,10 +2867,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2884,10 +2884,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2901,10 +2901,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2918,10 +2918,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2935,10 +2935,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2952,10 +2952,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2969,10 +2969,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -2986,10 +2986,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3338,10 +3338,10 @@ 12429 brk(0x1476e000) = 0x1476e000 12429 brk(0x1478f000) = 0x1478f000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3357,10 +3357,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 brk(0x14e3d000) = 0x14e3d000 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3375,10 +3375,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3393,10 +3393,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3410,10 +3410,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3427,10 +3427,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3444,10 +3444,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3461,10 +3461,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3478,10 +3478,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3495,10 +3495,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3512,10 +3512,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3529,10 +3529,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3546,10 +3546,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3563,10 +3563,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3580,10 +3580,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3597,10 +3597,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) @@ -3614,10 +3614,10 @@ 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libstd_scalls.so", F_OK) = -1 ENOENT (No such file or directory) 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libstd_scalls.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_k1c.so", F_OK) = -1 ENOENT (No such file or directory) -12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_k1c.so", F_OK) = 0 +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib32/libiss_kvx.so", F_OK) = -1 ENOENT (No such file or directory) +12429 access("/opt/Kalray/usr/local/k1rdtools/bin/../lib64/libiss_kvx.so", F_OK) = 0 12429 readlink("/proc/self/exe", "/opt/Kalray/usr/local/k1rdtools/"..., 1024) = 46 12429 getcwd("/home/monniaux/work/Kalray/tests/ocaml-4.07.1/byterun", 1024) = 54 12429 access("/opt/Kalray/usr/local/k1rdtools/bin/libmppa_multiloader.so", F_OK) = -1 ENOENT (No such file or directory) diff --git a/test/monniaux/picosat-965/Makefile b/test/monniaux/picosat-965/Makefile index a887c0de..4d6eee20 100644 --- a/test/monniaux/picosat-965/Makefile +++ b/test/monniaux/picosat-965/Makefile @@ -7,5 +7,5 @@ ALL_CFILES=picosat.c version.c app.c main.c include ../rules.mk # FIXME - what were these for? -#K1C_CFLAGS += $(EMBEDDED_CFLAGS) -#K1C_CCOMPFLAGS += $(EMBEDDED_CFLAGS) +#KVX_CFLAGS += $(EMBEDDED_CFLAGS) +#KVX_CCOMPFLAGS += $(EMBEDDED_CFLAGS) diff --git a/test/monniaux/quest/Makefile b/test/monniaux/quest/Makefile index c049238b..ef0b7db8 100644 --- a/test/monniaux/quest/Makefile +++ b/test/monniaux/quest/Makefile @@ -4,19 +4,19 @@ MAX=300 include ../rules.mk QUEST=quest -K1C_CCOMPFLAGS += -fstruct-passing -fbitfields +KVX_CCOMPFLAGS += -fstruct-passing -fbitfields PREFIX=ran%06.f TARGETS_C=$(shell seq --format $(PREFIX).c 0 $(MAX)) -TARGETS_OUT=$(shell seq --format $(PREFIX).ccomp.k1c.out 0 $(MAX)) +TARGETS_OUT=$(shell seq --format $(PREFIX).ccomp.kvx.out 0 $(MAX)) all: $(TARGETS_C) $(TARGETS_OUT) ran%.c : $(QUEST) -seed $* -test ansi > $@ -%.ccomp.k1c : %.ccomp.k1c.s - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +%.ccomp.kvx : %.ccomp.kvx.s + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ clean: -rm -f $(TARGETS_C) $(TARGETS_OUT) diff --git a/test/monniaux/quicksort/quicksort.ccomp.k1c.s_modified5 b/test/monniaux/quicksort/quicksort.ccomp.k1c.s_modified5 index 8a9a75bb..d1379555 100644 --- a/test/monniaux/quicksort/quicksort.ccomp.k1c.s_modified5 +++ b/test/monniaux/quicksort/quicksort.ccomp.k1c.s_modified5 @@ -1,5 +1,5 @@ # File generated by CompCert 3.4 -# Command line: -Wall -O3 -S quicksort.c -o quicksort.ccomp.k1c.s +# Command line: -Wall -O3 -S quicksort.c -o quicksort.ccomp.kvx.s .text .balign 2 .globl quicksort diff --git a/test/monniaux/quicksort/quicksort.ccomp.k1c.s_orig b/test/monniaux/quicksort/quicksort.ccomp.k1c.s_orig index 64c1e2bf..b83b9a64 100644 --- a/test/monniaux/quicksort/quicksort.ccomp.k1c.s_orig +++ b/test/monniaux/quicksort/quicksort.ccomp.k1c.s_orig @@ -1,5 +1,5 @@ # File generated by CompCert 3.4 -# Command line: -Wall -O3 -S quicksort.c -o quicksort.ccomp.k1c.s +# Command line: -Wall -O3 -S quicksort.c -o quicksort.ccomp.kvx.s .text .balign 2 .globl quicksort diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk index 2de2c466..f0db6afa 100644 --- a/test/monniaux/rules.mk +++ b/test/monniaux/rules.mk @@ -18,14 +18,14 @@ MAX_MEASURES=10 MEASURES?=time # Flags common to both compilers, then to gcc, then to ccomp -ALL_CFLAGS+=-Wall -D__K1C_COS__ -DMAX_MEASURES=$(MAX_MEASURES) +ALL_CFLAGS+=-Wall -D__KVX_COS__ -DMAX_MEASURES=$(MAX_MEASURES) #ALL_CFLAGS+=-g ALL_GCCFLAGS+=$(ALL_CFLAGS) -std=c99 -Wextra -Werror=implicit ALL_CCOMPFLAGS+=$(ALL_CFLAGS) # The compilers -K1C_CC?=k1-cos-gcc -K1C_CCOMP?=ccomp +KVX_CC?=k1-cos-gcc +KVX_CCOMP?=ccomp # Command to execute #EXECUTE_CYCLES?=timeout --signal=SIGTERM 3m k1-cluster --syscall=libstd_scalls.so --cycle-based -- @@ -75,7 +75,7 @@ asm/%$(3).s: %.c $(1) $(2) -S $$< -o $$@ .SECONDARY: -bin/$(TARGET)$(3).bin: $(addprefix obj/,$(ALL_CFILES:.c=$(3).o)) $(CLOCK).gcc.k1c.o +bin/$(TARGET)$(3).bin: $(addprefix obj/,$(ALL_CFILES:.c=$(3).o)) $(CLOCK).gcc.kvx.o @mkdir -p $$(@D) $(1) $$+ -lm -o $$@ @@ -86,13 +86,13 @@ FIRSTLINE:=$(FIRSTLINE), $(3) endef # Clock generation -$(CLOCK).gcc.k1c.o: $(CLOCK).c - $(K1C_CC) $(ALL_GCCFLAGS) -O3 $< -c -o $@ +$(CLOCK).gcc.kvx.o: $(CLOCK).c + $(KVX_CC) $(ALL_GCCFLAGS) -O3 $< -c -o $@ # Generic rules obj/%.o: asm/%.s @mkdir -p $(@D) - $(K1C_CC) $< -c -o $@ + $(KVX_CC) $< -c -o $@ out/%.out: bin/%.bin @mkdir -p $(@D) @@ -104,35 +104,35 @@ out/%.out: bin/%.bin ## ifneq ($(GCC0FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC0FLAGS),$(GCC0PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC0FLAGS),$(GCC0PREFIX))) endif ifneq ($(GCC1FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC1FLAGS),$(GCC1PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC1FLAGS),$(GCC1PREFIX))) endif ifneq ($(GCC2FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC2FLAGS),$(GCC2PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC2FLAGS),$(GCC2PREFIX))) endif ifneq ($(GCC3FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC3FLAGS),$(GCC3PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC3FLAGS),$(GCC3PREFIX))) endif ifneq ($(GCC4FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC4FLAGS),$(GCC4PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC4FLAGS),$(GCC4PREFIX))) endif ifneq ($(CCOMP0FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX))) endif ifneq ($(CCOMP1FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX))) endif ifneq ($(CCOMP2FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX))) endif ifneq ($(CCOMP3FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX))) endif ifneq ($(CCOMP4FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX))) endif measures.csv: $(OUTFILES) diff --git a/test/monniaux/sandbox/Makefile b/test/monniaux/sandbox/Makefile index 0fa2a2ae..c4a81f1c 100644 --- a/test/monniaux/sandbox/Makefile +++ b/test/monniaux/sandbox/Makefile @@ -8,20 +8,20 @@ ALL_CFILES=$(wildcard *.c) TARGET=toto # Name of the clock object -CLOCK=../clock.gcc.k1c.o +CLOCK=../clock.gcc.kvx.o # Maximum amount of time measures (see cycles.h) MAX_MEASURES=10 # Flags common to both compilers, then to gcc, then to ccomp -ALL_CFLAGS=-Wall -D__K1C_COS__ -DMAX_MEASURES=$(MAX_MEASURES) +ALL_CFLAGS=-Wall -D__KVX_COS__ -DMAX_MEASURES=$(MAX_MEASURES) #ALL_CFLAGS+=-g ALL_GCCFLAGS=$(ALL_CFLAGS) -std=c99 -Wextra -Werror=implicit ALL_CCOMPFLAGS=$(ALL_CFLAGS) # The compilers -K1C_CC=k1-cos-gcc -K1C_CCOMP=ccomp +KVX_CC=k1-cos-gcc +KVX_CCOMP=ccomp # Command to execute EXECUTE_CYCLES=k1-cluster --syscall=libstd_scalls.so --cycle-based -- @@ -72,7 +72,7 @@ asm/%$(3).s: %.c .SECONDARY: bin/$(TARGET)$(3).bin: $(addprefix obj/,$(ALL_CFILES:.c=$(3).o)) $(CLOCK) @mkdir -p $$(@D) - $(K1C_CC) $$+ -lm -o $$@ + $(KVX_CC) $$+ -lm -o $$@ BINFILES:=$(BINFILES) bin/$(TARGET)$(3).bin OUTFILES:=$(OUTFILES) out/$(TARGET)$(3).out @@ -83,7 +83,7 @@ endef # Generic rules obj/%.o: asm/%.s @mkdir -p $(@D) - $(K1C_CC) $< -c -o $@ + $(KVX_CC) $< -c -o $@ out/%.out: bin/%.bin @mkdir -p $(@D) @@ -94,35 +94,35 @@ out/%.out: bin/%.bin ## ifneq ($(GCC0FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC0FLAGS),$(GCC0PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC0FLAGS),$(GCC0PREFIX))) endif ifneq ($(GCC1FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC1FLAGS),$(GCC1PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC1FLAGS),$(GCC1PREFIX))) endif ifneq ($(GCC2FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC2FLAGS),$(GCC2PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC2FLAGS),$(GCC2PREFIX))) endif ifneq ($(GCC3FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC3FLAGS),$(GCC3PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC3FLAGS),$(GCC3PREFIX))) endif ifneq ($(GCC4FLAGS),) -$(eval $(call gen_rules,$(K1C_CC),$(GCC4FLAGS),$(GCC4PREFIX))) +$(eval $(call gen_rules,$(KVX_CC),$(GCC4FLAGS),$(GCC4PREFIX))) endif ifneq ($(CCOMP0FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX))) endif ifneq ($(CCOMP1FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX))) endif ifneq ($(CCOMP2FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX))) endif ifneq ($(CCOMP3FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX))) endif ifneq ($(CCOMP4FLAGS),) -$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX))) +$(eval $(call gen_rules,$(KVX_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX))) endif measures.csv: $(OUTFILES) diff --git a/test/monniaux/send_through/Makefile b/test/monniaux/send_through/Makefile index 72b84654..b2ab4e8e 100644 --- a/test/monniaux/send_through/Makefile +++ b/test/monniaux/send_through/Makefile @@ -1,10 +1,10 @@ -send_through: send_through_gcc.k1c.o send_through_ccomp.k1c.o +send_through: send_through_gcc.kvx.o send_through_ccomp.kvx.o ../../../ccomp -Wall $+ -o $@ -lm -send_through_gcc.k1c.o send_through_ccomp.k1c.o: send_through.h +send_through_gcc.kvx.o send_through_ccomp.kvx.o: send_through.h -send_through_gcc.k1c.o : send_through_gcc.c +send_through_gcc.kvx.o : send_through_gcc.c k1-cos-gcc -Wall -Wextra -std=c99 -Werror=implicit -c $< -o $@ -send_through_ccomp.k1c.o : send_through_ccomp.c +send_through_ccomp.kvx.o : send_through_ccomp.c ../../../ccomp -Wall -fnone -fvararg-calls -c $< -o $@ diff --git a/test/monniaux/varargs/Makefile b/test/monniaux/varargs/Makefile index f24d41ac..938eff30 100644 --- a/test/monniaux/varargs/Makefile +++ b/test/monniaux/varargs/Makefile @@ -1,9 +1,9 @@ include ../rules.mk -all: varargs.ccomp.k1c.s varargs.ccomp.k1c +all: varargs.ccomp.kvx.s varargs.ccomp.kvx -varargs.ccomp.k1c: varargs.ccomp.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +varargs.ccomp.kvx: varargs.ccomp.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ clean: - $(RM) -f *.k1c *.host *.o *.s + $(RM) -f *.kvx *.host *.o *.s diff --git a/test/monniaux/vocabulary.sh b/test/monniaux/vocabulary.sh index 5b76921e..eb3b70b6 100755 --- a/test/monniaux/vocabulary.sh +++ b/test/monniaux/vocabulary.sh @@ -1,2 +1,2 @@ -cat *.gcc.k1c.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > gcc_vocabulary.txt -cat *.ccomp.k1c.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > ccomp_vocabulary.txt +cat *.gcc.kvx.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > gcc_vocabulary.txt +cat *.ccomp.kvx.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > ccomp_vocabulary.txt diff --git a/test/monniaux/yarpgen/Makefile.old b/test/monniaux/yarpgen/Makefile.old index 9da82deb..316ec0f1 100644 --- a/test/monniaux/yarpgen/Makefile.old +++ b/test/monniaux/yarpgen/Makefile.old @@ -3,35 +3,35 @@ MAX=300 PREFIX=ran%06.f include ../rules.mk -K1C_CCOMPFLAGS += -funprototyped -fbitfields +KVX_CCOMPFLAGS += -funprototyped -fbitfields CCOMPFLAGS += -funprototyped -fbitfields TARGETS_C=$(shell seq --format $(PREFIX)/func.c 0 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.c 0 $(MAX)) \ $(shell seq --format $(PREFIX)/init.h 0 $(MAX)) -TARGETS_CCOMP_K1C_S=$(shell seq --format $(PREFIX)/func.ccomp.k1c.s 0 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.ccomp.k1c.s 0 $(MAX)) -TARGETS_GCC_K1C_S=$(shell seq --format $(PREFIX)/func.gcc.k1c.s 0 $(MAX)) \ - $(shell seq --format $(PREFIX)/driver.gcc.k1c.s 0 $(MAX)) +TARGETS_CCOMP_KVX_S=$(shell seq --format $(PREFIX)/func.ccomp.kvx.s 0 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.ccomp.kvx.s 0 $(MAX)) +TARGETS_GCC_KVX_S=$(shell seq --format $(PREFIX)/func.gcc.kvx.s 0 $(MAX)) \ + $(shell seq --format $(PREFIX)/driver.gcc.kvx.s 0 $(MAX)) TARGETS_CCOMP_HOST_S=$(shell seq --format $(PREFIX)/func.ccomp.host.s 0 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.ccomp.host.s 0 $(MAX)) TARGETS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 0 $(MAX)) \ $(shell seq --format $(PREFIX)/driver.gcc.host.s 0 $(MAX)) -TARGETS_CCOMP_K1C_OUT=$(shell seq --format $(PREFIX)/example.ccomp.k1c.out 0 $(MAX)) -TARGETS_GCC_K1C_OUT=$(shell seq --format $(PREFIX)/example.gcc.k1c.out 0 $(MAX)) +TARGETS_CCOMP_KVX_OUT=$(shell seq --format $(PREFIX)/example.ccomp.kvx.out 0 $(MAX)) +TARGETS_GCC_KVX_OUT=$(shell seq --format $(PREFIX)/example.gcc.kvx.out 0 $(MAX)) TARGETS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 0 $(MAX)) TARGETS_CCOMP_HOST_OUT=$(shell seq --format $(PREFIX)/example.ccomp.host.out 0 $(MAX)) -TARGETS_CMP=$(shell seq --format $(PREFIX)/example.k1c.cmp 0 $(MAX)) +TARGETS_CMP=$(shell seq --format $(PREFIX)/example.kvx.cmp 0 $(MAX)) -all: $(TARGETS_CCOMP_K1C_OUT) $(TARGETS_GCC_K1C_OUT) $(TARGETS_GCC_HOST_OUT) $(TARGETS_CCOMP_HOST_OUT) $(TARGETS_CCOMP_K1C_S) $(TARGETS_GCC_K1C_S) $(TARGETS_GCC_HOST_S) $(TARGETS_CCOMP_HOST_S) $(TARGETS_CMP) $(TARGETS_C) +all: $(TARGETS_CCOMP_KVX_OUT) $(TARGETS_GCC_KVX_OUT) $(TARGETS_GCC_HOST_OUT) $(TARGETS_CCOMP_HOST_OUT) $(TARGETS_CCOMP_KVX_S) $(TARGETS_GCC_KVX_S) $(TARGETS_GCC_HOST_S) $(TARGETS_CCOMP_HOST_S) $(TARGETS_CMP) $(TARGETS_C) -ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h +ran%/func.ccomp.kvx.s ran%/func.gcc.kvx.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h -ran%/example.ccomp.k1c: ran%/func.ccomp.k1c.o ran%/driver.ccomp.k1c.o - $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ +ran%/example.ccomp.kvx: ran%/func.ccomp.kvx.o ran%/driver.ccomp.kvx.o + $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -o $@ -ran%/example.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o - $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ +ran%/example.gcc.kvx: ran%/func.gcc.kvx.o ran%/driver.gcc.kvx.o + $(KVX_CC) $(KVX_CFLAGS) $+ -o $@ ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o $(CC) $(CFLAGS) $+ -o $@ @@ -43,7 +43,7 @@ ran%/driver.c ran%/func.c ran%/init.h: -mkdir ran$* $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99 -ran%/example.k1c.cmp : ran%/example.gcc.k1c.out ran%/example.ccomp.k1c.out +ran%/example.kvx.cmp : ran%/example.gcc.kvx.out ran%/example.ccomp.kvx.out cmp $+ > $@ .PHONY: all clean diff --git a/test/monniaux/zlib-1.2.11/Makefile b/test/monniaux/zlib-1.2.11/Makefile index 9e6920f5..52a7257b 100644 --- a/test/monniaux/zlib-1.2.11/Makefile +++ b/test/monniaux/zlib-1.2.11/Makefile @@ -14,7 +14,7 @@ include ../rules.mk # #src=$(wildcard *.c) # -#PRODUCTS?=minigzip.gcc.host minigzip.ccomp.host minigzip.gcc.k1c minigzip.gcc.o1.k1c minigzip.ccomp.k1c +#PRODUCTS?=minigzip.gcc.host minigzip.ccomp.host minigzip.gcc.kvx minigzip.gcc.o1.kvx minigzip.ccomp.kvx #PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS)) # #all: $(PRODUCTS) @@ -27,15 +27,15 @@ include ../rules.mk # $(CC) $(CFLAGS) $+ -lm -o $@ #minigzip.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o # $(CCOMP) $(CCOMPFLAGS) $+ -lm -o $@ -#minigzip.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS) $+ -lm -o $@ -#minigzip.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o -# $(K1C_CC) $(K1C_CFLAGS_O1) $+ -lm -o $@ -#minigzip.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o -# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -lm -o $@ +#minigzip.gcc.kvx: $(src:.c=.gcc.kvx.o) ../clock.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS) $+ -lm -o $@ +#minigzip.gcc.o1.kvx: $(src:.c=.gcc.o1.kvx.o) ../clock.gcc.kvx.o +# $(KVX_CC) $(KVX_CFLAGS_O1) $+ -lm -o $@ +#minigzip.ccomp.kvx: $(src:.c=.ccomp.kvx.o) ../clock.gcc.kvx.o +# $(KVX_CCOMP) $(KVX_CCOMPFLAGS) $+ -lm -o $@ #measures.csv: $(PRODUCTS_OUT) -# echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@ -# echo "zlib ", $$(grep 'cycles' minigzip.gcc.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.k1c.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.o1.k1c.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.k1c.out | cut -d':' -f2)>> $@ +# echo "benches, gcc host,ccomp host,gcc kvx,gcc o1 kvx,ccomp kvx" > $@ +# echo "zlib ", $$(grep 'cycles' minigzip.gcc.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.kvx.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.o1.kvx.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.kvx.out | cut -d':' -f2)>> $@ # #SAMPLE_FILE=zlib.h # @@ -45,18 +45,18 @@ include ../rules.mk #minigzip.ccomp.host.out minigzip.ccomp.host.output: minigzip.ccomp.host # ./$< < $(SAMPLE_FILE) > $<.output 2> $@ # -#minigzip.gcc.k1c.out minigzip.gcc.k1c.output: minigzip.gcc.k1c +#minigzip.gcc.kvx.out minigzip.gcc.kvx.output: minigzip.gcc.kvx # $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ # -#minigzip.gcc.o1.k1c.out minigzip.gcc.o1.k1c.output: minigzip.gcc.o1.k1c +#minigzip.gcc.o1.kvx.out minigzip.gcc.o1.kvx.output: minigzip.gcc.o1.kvx # $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ # -#minigzip.ccomp.k1c.out minigzip.ccomp.k1c.output: minigzip.ccomp.k1c +#minigzip.ccomp.kvx.out minigzip.ccomp.kvx.output: minigzip.ccomp.kvx # $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@ # #.SECONDARY: # #.PHONY: #clean: -# rm -f *.o *.s *.k1c *.csv +# rm -f *.o *.s *.kvx *.csv # diff --git a/test/mppa/.gitignore b/test/mppa/.gitignore index e8ebeff8..b10c40c8 100644 --- a/test/mppa/.gitignore +++ b/test/mppa/.gitignore @@ -6,15 +6,15 @@ prng/Makefile sort/Makefile prng/.zero sort/.zero -sort/insertion-ccomp-k1c -sort/insertion-gcc-k1c +sort/insertion-ccomp-kvx +sort/insertion-gcc-kvx sort/insertion-gcc-x86 -sort/main-ccomp-k1c -sort/main-gcc-k1c +sort/main-ccomp-kvx +sort/main-gcc-kvx sort/main-gcc-x86 -sort/merge-ccomp-k1c -sort/merge-gcc-k1c +sort/merge-ccomp-kvx +sort/merge-gcc-kvx sort/merge-gcc-x86 -sort/selection-ccomp-k1c -sort/selection-gcc-k1c +sort/selection-ccomp-kvx +sort/selection-gcc-kvx sort/selection-gcc-x86 diff --git a/test/mppa/builtins/stsud.c b/test/mppa/builtins/stsud.c index fb07b94f..fa42b001 100644 --- a/test/mppa/builtins/stsud.c +++ b/test/mppa/builtins/stsud.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 2) { - c = __builtin_k1_stsud(t[0], t[1]); + c = __builtin_kvx_stsud(t[0], t[1]); } END_TEST() diff --git a/test/mppa/coverage.sh b/test/mppa/coverage.sh index 42ed4182..96f6bc04 100755 --- a/test/mppa/coverage.sh +++ b/test/mppa/coverage.sh @@ -1,6 +1,6 @@ #!/bin/bash -printer=../../mppa_k1c/TargetPrinter.ml +printer=../../kvx/TargetPrinter.ml asmdir=instr/asm/ to_cover_raw=/tmp/to_cover_raw to_cover=/tmp/to_cover diff --git a/test/mppa/general/clzd.c b/test/mppa/general/clzd.c index 4bedab97..d3e8a8ec 100644 --- a/test/mppa/general/clzd.c +++ b/test/mppa/general/clzd.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 1) { - c = __builtin_k1_clzd(t[0]); + c = __builtin_kvx_clzd(t[0]); } END_TEST() diff --git a/test/mppa/general/clzw.c b/test/mppa/general/clzw.c index 361492f2..7b5478fd 100644 --- a/test/mppa/general/clzw.c +++ b/test/mppa/general/clzw.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 1) { - c = __builtin_k1_clzw(t[0]); + c = __builtin_kvx_clzw(t[0]); } END_TEST() diff --git a/test/mppa/general/ctzd.c b/test/mppa/general/ctzd.c index 6f6586ad..bba869e1 100644 --- a/test/mppa/general/ctzd.c +++ b/test/mppa/general/ctzd.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 1) { - c = __builtin_k1_ctzd(t[0]); + c = __builtin_kvx_ctzd(t[0]); } END_TEST() diff --git a/test/mppa/general/ctzw.c b/test/mppa/general/ctzw.c index b0f2c937..a7128b04 100644 --- a/test/mppa/general/ctzw.c +++ b/test/mppa/general/ctzw.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 1) { - c = __builtin_k1_ctzw(t[0]); + c = __builtin_kvx_ctzw(t[0]); } END_TEST() diff --git a/test/mppa/general/satd.c b/test/mppa/general/satd.c index d8d0d256..9d0d1cf9 100644 --- a/test/mppa/general/satd.c +++ b/test/mppa/general/satd.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 2) { - c = __builtin_k1_satd(t[0], t[1]); + c = __builtin_kvx_satd(t[0], t[1]); } END_TEST() diff --git a/test/mppa/general/sbmm8.c b/test/mppa/general/sbmm8.c index beced8fc..91f13425 100644 --- a/test/mppa/general/sbmm8.c +++ b/test/mppa/general/sbmm8.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 2) { - c = __builtin_k1_sbmm8(t[0], t[1]); + c = __builtin_kvx_sbmm8(t[0], t[1]); } END_TEST() diff --git a/test/mppa/general/sbmmt8.c b/test/mppa/general/sbmmt8.c index 8a64e7e7..7b120dfa 100644 --- a/test/mppa/general/sbmmt8.c +++ b/test/mppa/general/sbmmt8.c @@ -2,6 +2,6 @@ BEGIN_TEST_N(unsigned long long, 2) { - c = __builtin_k1_sbmmt8(t[0], t[1]); + c = __builtin_kvx_sbmmt8(t[0], t[1]); } END_TEST() diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile index 37f7d0ab..e4f964b3 100644 --- a/test/mppa/instr/Makefile +++ b/test/mppa/instr/Makefile @@ -1,6 +1,6 @@ SHELL := /bin/bash -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc CC ?= gcc CCOMP ?= ccomp OPTIM ?= -O2 @@ -24,7 +24,7 @@ K1LIB=../lib/system.gcc.a # -> .ccomp.s -> .ccomp.bin -> .ccomp.out ## -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) CCPATH=$(shell which $(CC)) CCOMPPATH=$(shell which $(CCOMP)) SIMUPATH=$(shell which $(SIMU)) @@ -63,8 +63,8 @@ simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) for test in $(TESTNAMES); do\ x86out=$(OUTDIR)/$$test.x86-gcc.out;\ gccout=$(OUTDIR)/$$test.gcc.simu.out;\ - if grep "__K1C__" -q $$test.c; then\ - printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\n";\ + if grep "__KVX__" -q $$test.c; then\ + printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ else\ @@ -91,8 +91,8 @@ hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) for test in $(TESTNAMES); do\ x86out=$(OUTDIR)/$$test.x86-gcc.out;\ gccout=$(OUTDIR)/$$test.gcc.hard.out;\ - if grep "__K1C__" -q $$test.c; then\ - printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\n";\ + if grep "__KVX__" -q $$test.c; then\ + printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ else\ @@ -153,9 +153,9 @@ $(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(LIB) $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ -$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1LIB) $(K1CCPATH) +$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1LIB) $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ $(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(K1LIB) $(CCOMPPATH) @mkdir -p $(@D) @@ -167,9 +167,9 @@ $(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) -S $< -o $@ -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH) +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) -S $< -o $@ + $(KVXC) $(CFLAGS) -S $< -o $@ $(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) @mkdir -p $(@D) diff --git a/test/mppa/instr/builtin32.c b/test/mppa/instr/builtin32.c index c7689dc8..9efb33cd 100644 --- a/test/mppa/instr/builtin32.c +++ b/test/mppa/instr/builtin32.c @@ -2,9 +2,9 @@ BEGIN_TEST(int) int *ptr = &c; -#ifdef __K1C__ +#ifdef __KVX__ int d = c; - a = __builtin_k1_alclrw(ptr); + a = __builtin_kvx_alclrw(ptr); c = d; #endif diff --git a/test/mppa/instr/builtin64.c b/test/mppa/instr/builtin64.c index dbbb1886..252eb2c6 100644 --- a/test/mppa/instr/builtin64.c +++ b/test/mppa/instr/builtin64.c @@ -2,16 +2,16 @@ BEGIN_TEST(long long) long long *ptr = &c; -#ifdef __K1C__ +#ifdef __KVX__ long long d = c; - a = __builtin_k1_alclrd(ptr); + a = __builtin_kvx_alclrd(ptr); c = d; c += a; c += __builtin_clzll(a); /* Removed the AFADDD builtin who was incorrect in CompCert, see #157 */ - // a = __builtin_k1_afaddd(ptr, a); - // a = __builtin_k1_afaddd(ptr, a); + // a = __builtin_kvx_afaddd(ptr, a); + // a = __builtin_kvx_afaddd(ptr, a); #endif END_TEST64() diff --git a/test/mppa/interop/Makefile b/test/mppa/interop/Makefile index 3a83d51c..a0d4d7da 100644 --- a/test/mppa/interop/Makefile +++ b/test/mppa/interop/Makefile @@ -1,6 +1,6 @@ SHELL := /bin/bash -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc CC ?= gcc CCOMP ?= ccomp CFLAGS ?= -O2 -Wno-varargs @@ -26,7 +26,7 @@ VAARG_COMMON=vaarg_common # There is also a $(VAARG_COMMON) that is the same than $(COMMON) but with va_arg ## -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) CCPATH=$(shell which $(CC)) CCOMPPATH=$(shell which $(CCOMP)) SIMUPATH=$(shell which $(SIMU)) @@ -273,9 +273,9 @@ $(BINDIR)/$(COMMON).x86-gcc.bin: $(OBJDIR)/$(COMMON).x86-gcc.o $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) $< -o $@ -$(BINDIR)/$(COMMON).gcc.bin: $(OBJDIR)/$(COMMON).gcc.o $(K1CCPATH) +$(BINDIR)/$(COMMON).gcc.bin: $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $< -o $@ + $(KVXC) $(CFLAGS) $< -o $@ $(BINDIR)/$(COMMON).ccomp.bin: $(OBJDIR)/$(COMMON).ccomp.o $(CCOMPPATH) @mkdir -p $(@D) @@ -287,9 +287,9 @@ $(BINDIR)/$(VAARG_COMMON).x86-gcc.bin: $(OBJDIR)/$(VAARG_COMMON).x86-gcc.o $(CCP @mkdir -p $(@D) $(CC) $(CFLAGS) $< -o $@ -$(BINDIR)/$(VAARG_COMMON).gcc.bin: $(OBJDIR)/$(VAARG_COMMON).gcc.o $(K1CCPATH) +$(BINDIR)/$(VAARG_COMMON).gcc.bin: $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $< -o $@ + $(KVXC) $(CFLAGS) $< -o $@ $(BINDIR)/$(VAARG_COMMON).ccomp.bin: $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(CCOMPPATH) @mkdir -p $(@D) @@ -301,11 +301,11 @@ $(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(COMMON).x86-gcc.o $(C @mkdir -p $(@D) $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ -$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).gcc.o $(K1CCPATH) +$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ -$(BINDIR)/%.gcc.rev.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).ccomp.o $(K1CCPATH) +$(BINDIR)/%.gcc.rev.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).ccomp.o $(KVXCPATH) @mkdir -p $(@D) $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ @@ -319,11 +319,11 @@ $(BINDIR)/%.x86-gcc.vaarg.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(VAARG_COMMON).x @mkdir -p $(@D) $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ -$(BINDIR)/%.gcc.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(K1CCPATH) +$(BINDIR)/%.gcc.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ -$(BINDIR)/%.gcc.rev.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(K1CCPATH) +$(BINDIR)/%.gcc.rev.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(KVXCPATH) @mkdir -p $(@D) $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ @@ -339,9 +339,9 @@ $(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) @mkdir -p $(@D) $(CC) -c $(CFLAGS) $< -o $@ -$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(K1CCPATH) +$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) -c $(CFLAGS) $< -o $@ + $(KVXC) -c $(CFLAGS) $< -o $@ $(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) @mkdir -p $(@D) @@ -356,9 +356,9 @@ $(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) -S $< -o $@ -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH) +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) -S $< -o $@ + $(KVXC) $(CFLAGS) -S $< -o $@ $(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) @mkdir -p $(@D) diff --git a/test/mppa/lib/Makefile b/test/mppa/lib/Makefile index 08901db6..5a947bb3 100644 --- a/test/mppa/lib/Makefile +++ b/test/mppa/lib/Makefile @@ -1,4 +1,4 @@ -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc K1AR ?= k1-cos-ar CC ?= gcc AR ?= gcc-ar @@ -14,7 +14,7 @@ BINDIR=$(DIR)/bin ASMDIR=$(DIR)/asm OBJDIR=$(DIR)/obj -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) K1ARPATH=$(shell which $(K1AR)) CCPATH=$(shell which $(CC)) ARPATH=$(shell which $(AR)) @@ -89,9 +89,9 @@ $(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o system.x86-gcc.a $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ -$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o system.gcc.a $(K1CCPATH) +$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o system.gcc.a $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ $(BINDIR)/%.ccomp.bin: $(OBJDIR)/%.ccomp.o system.gcc.a $(CCOMPPATH) @mkdir -p $(@D) @@ -110,9 +110,9 @@ $(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) -c $< -o $@ -$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(K1CCPATH) +$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) -c $< -o $@ + $(KVXC) $(CFLAGS) -c $< -o $@ $(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) $(CCOMP) $(CFLAGS) -c $< -o $@ @@ -123,9 +123,9 @@ $(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) @mkdir -p $(@D) $(CC) $(CFLAGS) -S $< -o $@ -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH) +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) @mkdir -p $(@D) - $(K1CC) $(CFLAGS) -S $< -o $@ + $(KVXC) $(CFLAGS) -S $< -o $@ $(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) @mkdir -p $(@D) diff --git a/test/mppa/mmult/.gitignore b/test/mppa/mmult/.gitignore index c9cd4c65..b43ccc5f 100644 --- a/test/mppa/mmult/.gitignore +++ b/test/mppa/mmult/.gitignore @@ -1,4 +1,4 @@ -mmult-test-ccomp-k1c -mmult-test-gcc-k1c +mmult-test-ccomp-kvx +mmult-test-gcc-kvx mmult-test-gcc-x86 .zero diff --git a/test/mppa/mmult/Makefile b/test/mppa/mmult/Makefile index 667faef8..e7cd890e 100644 --- a/test/mppa/mmult/Makefile +++ b/test/mppa/mmult/Makefile @@ -1,20 +1,20 @@ -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc CC ?= gcc CCOMP ?= ccomp CFLAGS ?= -O2 SIMU ?= k1-mppa TIMEOUT ?= 10s -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) CCPATH=$(shell which $(CC)) CCOMPPATH=$(shell which $(CCOMP)) SIMUPATH=$(shell which $(SIMU)) PRNG=../prng/prng.c -ALL= mmult-test-gcc-x86 mmult-test-gcc-k1c mmult-test-ccomp-k1c -CCOMP_OUT= mmult-test-ccomp-k1c.out -GCC_OUT= mmult-test-gcc-k1c.out +ALL= mmult-test-gcc-x86 mmult-test-gcc-kvx mmult-test-ccomp-kvx +CCOMP_OUT= mmult-test-ccomp-kvx.out +GCC_OUT= mmult-test-gcc-kvx.out X86_GCC_OUT= mmult-test-gcc-x86.out STUB_OUT=.zero @@ -23,14 +23,14 @@ all: $(ALL) mmult-test-gcc-x86: mmult.c $(PRNG) $(CCPATH) $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ -mmult-test-gcc-k1c: mmult.c $(PRNG) $(K1CCPATH) - $(K1CC) $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ +mmult-test-gcc-kvx: mmult.c $(PRNG) $(KVXCPATH) + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ -mmult-test-ccomp-k1c: mmult.c $(PRNG) $(CCOMPPATH) +mmult-test-ccomp-kvx: mmult.c $(PRNG) $(CCOMPPATH) $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ .SECONDARY: -%k1c.out: %k1c $(SIMUPATH) +%kvx.out: %kvx $(SIMUPATH) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ %x86.out: %x86 @@ -40,7 +40,7 @@ mmult-test-ccomp-k1c: mmult.c $(PRNG) $(CCOMPPATH) @echo "0" > $@ .PHONY: -test: test-x86 test-k1c +test: test-x86 test-kvx .PHONY: test-x86: $(X86_GCC_OUT) $(STUB_OUT) @@ -51,17 +51,17 @@ test-x86: $(X86_GCC_OUT) $(STUB_OUT) fi .PHONY: -test-k1c: $(GCC_OUT) $(STUB_OUT) +test-kvx: $(GCC_OUT) $(STUB_OUT) @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $< failed";\ + >&2 echo "ERROR kvx: $< failed";\ else\ - echo "GOOD k1c: $< succeeded";\ + echo "GOOD kvx: $< succeeded";\ fi .PHONY: check: $(CCOMP_OUT) $(STUB_OUT) @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $< failed";\ + >&2 echo "ERROR kvx: $< failed";\ else\ - echo "GOOD k1c: $< succeeded";\ + echo "GOOD kvx: $< succeeded";\ fi diff --git a/test/mppa/mmult/README.md b/test/mppa/mmult/README.md index ef2bff7e..780603f6 100644 --- a/test/mppa/mmult/README.md +++ b/test/mppa/mmult/README.md @@ -11,7 +11,7 @@ The following commands can be run inside the folder: - `make`: produces the unitary test binaries - `mmult-test-gcc-x86` : binary from gcc on x86 - - `mmult-test-k1c-x86` : binary from gcc on k1c - - `mmult-test-ccomp-x86` : binary from ccomp on k1c + - `mmult-test-kvx-x86` : binary from gcc on kvx + - `mmult-test-ccomp-x86` : binary from ccomp on kvx - `make test`: tests the return value of the binaries produced by gcc. - `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/prng/.gitignore b/test/mppa/prng/.gitignore index 0792a78b..08023900 100644 --- a/test/mppa/prng/.gitignore +++ b/test/mppa/prng/.gitignore @@ -1,3 +1,3 @@ -prng-test-ccomp-k1c +prng-test-ccomp-kvx prng-test-gcc-x86 -prng-test-gcc-k1c +prng-test-gcc-kvx diff --git a/test/mppa/prng/Makefile b/test/mppa/prng/Makefile index 9cbb3872..68e5ffc9 100644 --- a/test/mppa/prng/Makefile +++ b/test/mppa/prng/Makefile @@ -1,18 +1,18 @@ -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc CC ?= gcc CCOMP ?= ccomp CFLAGS ?= -O2 SIMU ?= k1-mppa TIMEOUT ?= 10s -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) CCPATH=$(shell which $(CC)) CCOMPPATH=$(shell which $(CCOMP)) SIMUPATH=$(shell which $(SIMU)) -ALL= prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c -CCOMP_OUT= prng-test-ccomp-k1c.out -GCC_OUT= prng-test-gcc-k1c.out +ALL= prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx +CCOMP_OUT= prng-test-ccomp-kvx.out +GCC_OUT= prng-test-gcc-kvx.out X86_GCC_OUT= prng-test-gcc-x86.out STUB_OUT=.zero @@ -21,14 +21,14 @@ all: $(ALL) prng-test-gcc-x86: prng.c $(CCPATH) $(CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ -prng-test-gcc-k1c: prng.c $(K1CCPATH) - $(K1CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ +prng-test-gcc-kvx: prng.c $(KVXCPATH) + $(KVXC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ -prng-test-ccomp-k1c: prng.c $(CCOMPPATH) +prng-test-ccomp-kvx: prng.c $(CCOMPPATH) $(CCOMP) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ .SECONDARY: -%k1c.out: %k1c $(SIMUPATH) +%kvx.out: %kvx $(SIMUPATH) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ %x86.out: %x86 @@ -38,7 +38,7 @@ prng-test-ccomp-k1c: prng.c $(CCOMPPATH) @echo "0" > $@ .PHONY: -test: test-x86 test-k1c +test: test-x86 test-kvx .PHONY: test-x86: $(X86_GCC_OUT) $(STUB_OUT) @@ -49,21 +49,21 @@ test-x86: $(X86_GCC_OUT) $(STUB_OUT) fi .PHONY: -test-k1c: $(GCC_OUT) $(STUB_OUT) +test-kvx: $(GCC_OUT) $(STUB_OUT) @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $< failed";\ + >&2 echo "ERROR kvx: $< failed";\ else\ - echo "GOOD k1c: $< succeeded";\ + echo "GOOD kvx: $< succeeded";\ fi .PHONY: check: $(CCOMP_OUT) $(STUB_OUT) @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $< failed";\ + >&2 echo "ERROR kvx: $< failed";\ else\ - echo "GOOD k1c: $< succeeded";\ + echo "GOOD kvx: $< succeeded";\ fi .PHONY: clean: - rm -f prng-test-gcc-x86 prng-test-gcc-k1c prng-test-ccomp-k1c + rm -f prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx diff --git a/test/mppa/prng/README.md b/test/mppa/prng/README.md index b4c2279b..98ed539d 100644 --- a/test/mppa/prng/README.md +++ b/test/mppa/prng/README.md @@ -11,7 +11,7 @@ The following commands can be run inside that folder: - `make`: produces the unitary test binaries - `prng-test-gcc-x86` : binary from gcc on x86 - - `prng-test-k1c-x86` : binary from gcc on k1c - - `prng-test-ccomp-x86` : binary from ccomp on k1c + - `prng-test-kvx-x86` : binary from gcc on kvx + - `prng-test-ccomp-x86` : binary from ccomp on kvx - `make test`: tests the return value of the binaries produced by gcc. - `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/sort/.gitignore b/test/mppa/sort/.gitignore index a8d6921c..070b87c4 100644 --- a/test/mppa/sort/.gitignore +++ b/test/mppa/sort/.gitignore @@ -1,9 +1,9 @@ -main-test-ccomp-k1c -main-test-gcc-k1c +main-test-ccomp-kvx +main-test-gcc-kvx main-test-gcc-x86 -merge-test-gcc-k1c +merge-test-gcc-kvx merge-test-gcc-x86 -selection-test-gcc-k1c +selection-test-gcc-kvx selection-test-gcc-x86 -insertion-test-gcc-k1c +insertion-test-gcc-kvx insertion-test-gcc-x86 diff --git a/test/mppa/sort/Makefile b/test/mppa/sort/Makefile index 0ae9d1f6..c4090352 100644 --- a/test/mppa/sort/Makefile +++ b/test/mppa/sort/Makefile @@ -1,11 +1,11 @@ -K1CC ?= k1-cos-gcc +KVXC ?= k1-cos-gcc CC ?= gcc CCOMP ?= ccomp CFLAGS ?= -O2 SIMU ?= k1-mppa TIMEOUT ?= 10s -K1CCPATH=$(shell which $(K1CC)) +KVXCPATH=$(shell which $(KVXC)) CCPATH=$(shell which $(CC)) CCOMPPATH=$(shell which $(CCOMP)) SIMUPATH=$(shell which $(SIMU)) @@ -14,15 +14,15 @@ PRNG=../prng/prng.c CFILES=insertion.c merge.c selection.c main.c -ALL= insertion-gcc-x86 insertion-gcc-k1c insertion-ccomp-k1c\ - selection-gcc-x86 selection-gcc-k1c selection-ccomp-k1c\ - merge-gcc-x86 merge-gcc-k1c merge-ccomp-k1c\ - main-gcc-x86 main-gcc-k1c main-ccomp-k1c +ALL= insertion-gcc-x86 insertion-gcc-kvx insertion-ccomp-kvx\ + selection-gcc-x86 selection-gcc-kvx selection-ccomp-kvx\ + merge-gcc-x86 merge-gcc-kvx merge-ccomp-kvx\ + main-gcc-x86 main-gcc-kvx main-ccomp-kvx -CCOMP_OUT= insertion-ccomp-k1c.out selection-ccomp-k1c.out merge-ccomp-k1c.out\ - main-ccomp-k1c.out -GCC_OUT= insertion-gcc-k1c.out selection-gcc-k1c.out merge-gcc-k1c.out\ - main-gcc-k1c.out +CCOMP_OUT= insertion-ccomp-kvx.out selection-ccomp-kvx.out merge-ccomp-kvx.out\ + main-ccomp-kvx.out +GCC_OUT= insertion-gcc-kvx.out selection-gcc-kvx.out merge-gcc-kvx.out\ + main-gcc-kvx.out X86_GCC_OUT= insertion-gcc-x86.out selection-gcc-x86.out merge-gcc-x86.out\ main-gcc-x86.out STUB_OUT= .zero @@ -35,23 +35,23 @@ main-gcc-x86: $(CFILES) $(PRNG) $(CCPATH) %-gcc-x86: %.c $(PRNG) $(CCPATH) $(CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ -main-gcc-k1c: $(CFILES) $(PRNG) $(CCPATH) - $(K1CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ +main-gcc-kvx: $(CFILES) $(PRNG) $(CCPATH) + $(KVXC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ -%-gcc-k1c: %.c $(PRNG) $(K1CCPATH) - $(K1CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(K1CCPATH),$^) -o $@ +%-gcc-kvx: %.c $(PRNG) $(KVXCPATH) + $(KVXC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ -main-ccomp-k1c: $(CFILES) $(PRNG) $(CCOMPPATH) +main-ccomp-kvx: $(CFILES) $(PRNG) $(CCOMPPATH) $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ -%-ccomp-k1c: %.c $(PRNG) $(CCOMPPATH) +%-ccomp-kvx: %.c $(PRNG) $(CCOMPPATH) $(CCOMP) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ .SECONDARY: %x86.out: %x86 ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ -%k1c.out: %k1c $(SIMUPATH) +%kvx.out: %kvx $(SIMUPATH) ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ .zero: @@ -68,24 +68,24 @@ test-x86: $(STUB_OUT) $(X86_GCC_OUT) done .PHONY: -test-k1c: $(STUB_OUT) $(GCC_OUT) +test-kvx: $(STUB_OUT) $(GCC_OUT) @for test in $(wordlist 2,100,$^); do\ if ! diff $$test $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $$test failed";\ + >&2 echo "ERROR kvx: $$test failed";\ else\ - echo "GOOD k1c: $$test succeeded";\ + echo "GOOD kvx: $$test succeeded";\ fi;\ done .PHONY: -test: test-x86 test-k1c +test: test-x86 test-kvx .PHONY: check: $(STUB_OUT) $(CCOMP_OUT) @for test in $(wordlist 2,100,$^); do\ if ! diff $$test $(STUB_OUT); then\ - >&2 echo "ERROR k1c: $$test failed";\ + >&2 echo "ERROR kvx: $$test failed";\ else\ - echo "GOOD k1c: $$test succeeded";\ + echo "GOOD kvx: $$test succeeded";\ fi;\ done diff --git a/test/mppa/sort/README.md b/test/mppa/sort/README.md index b4c2279b..98ed539d 100644 --- a/test/mppa/sort/README.md +++ b/test/mppa/sort/README.md @@ -11,7 +11,7 @@ The following commands can be run inside that folder: - `make`: produces the unitary test binaries - `prng-test-gcc-x86` : binary from gcc on x86 - - `prng-test-k1c-x86` : binary from gcc on k1c - - `prng-test-ccomp-x86` : binary from ccomp on k1c + - `prng-test-kvx-x86` : binary from gcc on kvx + - `prng-test-ccomp-x86` : binary from ccomp on kvx - `make test`: tests the return value of the binaries produced by gcc. - `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/regression/Makefile b/test/regression/Makefile index 97c25f6c..744a2c03 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -26,7 +26,7 @@ TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ varargs1 varargs2 varargs3 sections alias aligned\ packedstruct1 packedstruct2 -ifeq ($(ARCH),mppa_k1c) +ifeq ($(ARCH),kvx) TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP)) TESTS_COMP:=$(filter-out packedstruct2,$(TESTS_COMP)) endif @@ -35,7 +35,7 @@ endif # but produce processor-dependent results, so no reference output in Results TESTS_DIFF=NaNs -# FIXME ifeq ($(ARCH),mppa_k1c) +# FIXME ifeq ($(ARCH),kvx) TESTS_DIFF:=$(filter-out NaNs,$(TESTS_DIFF)) # endif diff --git a/test/regression/extasm.c b/test/regression/extasm.c index 352b930b..e78fb741 100644 --- a/test/regression/extasm.c +++ b/test/regression/extasm.c @@ -24,7 +24,7 @@ int clobbers(int x, int z) || (defined(ARCH_riscV) && defined(MODEL_64)) \ || (defined(ARCH_powerpc) && defined(MODEL_ppc64)) \ || (defined(ARCH_powerpc) && defined(MODEL_e5500)) \ - || (defined(ARCH_mppa_k1c) && defined(MODEL_64)) \ + || (defined(ARCH_kvx) && defined(MODEL_64)) \ || defined(ARCH_aarch64) #define SIXTYFOUR #else diff --git a/test/regression/varargs2.c b/test/regression/varargs2.c index 84860ef3..3e785a63 100644 --- a/test/regression/varargs2.c +++ b/test/regression/varargs2.c @@ -122,12 +122,12 @@ int main() miniprintf("A string: %s\n", "Hello world"); miniprintf("A double: %e\n", 3.141592654); -#ifndef __K1C__ +#ifndef __KVX__ miniprintf("A small struct: %y\n", (struct Y) { 'x', 12 }); miniprintf("A bigger struct: %z\n", (struct Z) { 123, 456, 789 }); #endif -#ifdef __K1C__ +#ifdef __KVX__ miniprintf("A mixture: %c & %s & %d & %l & %e & %f\n", 'x', "Hello, world!", -- cgit From bc1e43ea95b9455cdccee442db77bc5fafd3dcc6 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Tue, 26 May 2020 22:11:32 +0200 Subject: tests for kvx --- test/c/Results/binarytrees-kvx | 4 + test/c/Results/binarytrees-mppa_k1c | 4 - test/c/Results/chomp-kvx | 9 + test/c/Results/chomp-mppa_k1c | 9 - test/c/Results/fannkuch-kvx | 31 ++ test/c/Results/fannkuch-mppa_k1c | 31 -- test/c/Results/fft-kvx | 1 + test/c/Results/fft-mppa_k1c | 1 - test/c/Results/fftsp-kvx | 1 + test/c/Results/fftsp-mppa_k1c | 1 - test/c/Results/fftw-kvx | 16 ++ test/c/Results/fftw-mppa_k1c | 16 -- test/c/Results/fib-kvx | 1 + test/c/Results/fib-mppa_k1c | 1 - test/c/Results/integr-kvx | 1 + test/c/Results/integr-mppa_k1c | 1 - test/c/Results/knucleotide-kvx | 0 test/c/Results/knucleotide-mppa_k1c | 0 test/c/Results/lists-kvx | 2 + test/c/Results/lists-mppa_k1c | 2 - test/c/Results/mandelbrot-kvx | Bin 0 -> 209 bytes test/c/Results/mandelbrot-mppa_k1c | Bin 209 -> 0 bytes test/c/Results/nbody-kvx | 2 + test/c/Results/nbody-mppa_k1c | 2 - test/c/Results/nsieve-kvx | 3 + test/c/Results/nsieve-mppa_k1c | 3 - test/c/Results/nsievebits-kvx | 3 + test/c/Results/nsievebits-mppa_k1c | 3 - test/c/Results/perlin-kvx | 1 + test/c/Results/perlin-mppa_k1c | 1 - test/c/Results/qsort-kvx | 1 + test/c/Results/qsort-mppa_k1c | 1 - test/c/Results/sha1-kvx | 2 + test/c/Results/sha1-mppa_k1c | 2 - test/c/Results/spectral-kvx | 1 + test/c/Results/spectral-mppa_k1c | 1 - test/c/Results/vmach-kvx | 2 + test/c/Results/vmach-mppa_k1c | 2 - test/kvx/.gitignore | 20 ++ test/kvx/builtins/clzll.c | 7 + test/kvx/builtins/stsud.c | 7 + test/kvx/coverage.sh | 24 ++ test/kvx/coverage_helper.py | 45 +++ test/kvx/delout.sh | 6 + test/kvx/do_test.sh | 50 ++++ test/kvx/general/clzd.c | 7 + test/kvx/general/clzw.c | 7 + test/kvx/general/ctzd.c | 7 + test/kvx/general/ctzw.c | 7 + test/kvx/general/satd.c | 7 + test/kvx/general/sbmm8.c | 7 + test/kvx/general/sbmmt8.c | 7 + test/kvx/hardcheck.sh | 6 + test/kvx/hardtest.sh | 6 + test/kvx/instr/.gitignore | 1 + test/kvx/instr/Makefile | 176 ++++++++++++ test/kvx/instr/builtin32.c | 12 + test/kvx/instr/builtin64.c | 17 ++ test/kvx/instr/div32.c | 5 + test/kvx/instr/divf32.c | 5 + test/kvx/instr/divf64.c | 5 + test/kvx/instr/divu32.c | 7 + test/kvx/instr/f32.c | 8 + test/kvx/instr/f64.c | 8 + test/kvx/instr/floatcmp.py | 93 ++++++ test/kvx/instr/framework.h | 66 +++++ test/kvx/instr/i32.c | 149 ++++++++++ test/kvx/instr/i64.c | 169 +++++++++++ test/kvx/instr/individual/andw.c | 5 + test/kvx/instr/individual/branch.c | 10 + test/kvx/instr/individual/branchz.c | 10 + test/kvx/instr/individual/branchzu.c | 11 + test/kvx/instr/individual/call.c | 16 ++ test/kvx/instr/individual/cast_S32_S64.c | 7 + test/kvx/instr/individual/cast_S64_U32.c | 7 + test/kvx/instr/individual/cb.deqz.c | 10 + test/kvx/instr/individual/cb.dgez.c | 10 + test/kvx/instr/individual/cb.dgtz.c | 10 + test/kvx/instr/individual/cb.dlez.c | 10 + test/kvx/instr/individual/cb.dltz.c | 10 + test/kvx/instr/individual/cb.dnez.c | 10 + test/kvx/instr/individual/cb.wgez.c | 10 + test/kvx/instr/individual/cb.wgtz.c | 10 + test/kvx/instr/individual/cb.wlez.c | 10 + test/kvx/instr/individual/cb.wltz.c | 10 + test/kvx/instr/individual/compd.eq.c | 7 + test/kvx/instr/individual/compd.geu.c | 7 + test/kvx/instr/individual/compd.gt.c | 7 + test/kvx/instr/individual/compd.le.c | 7 + test/kvx/instr/individual/compd.leu.c | 7 + test/kvx/instr/individual/compd.lt.c | 7 + test/kvx/instr/individual/compd.ltu.c | 7 + test/kvx/instr/individual/compd.ne.c | 7 + test/kvx/instr/individual/compw.eq.c | 7 + test/kvx/instr/individual/compw.geu.c | 7 + test/kvx/instr/individual/compw.gt.c | 7 + test/kvx/instr/individual/compw.gtu.c | 7 + test/kvx/instr/individual/compw.le.c | 7 + test/kvx/instr/individual/compw.leu.c | 7 + test/kvx/instr/individual/compw.lt.c | 7 + test/kvx/instr/individual/compw.ltu.c | 7 + test/kvx/instr/individual/compw.ne.c | 7 + test/kvx/instr/individual/div2.c | 7 + test/kvx/instr/individual/doubleconv.c | 9 + test/kvx/instr/individual/floatconv.c | 9 + test/kvx/instr/individual/fmuld.c | 7 + test/kvx/instr/individual/fmulw.c | 7 + test/kvx/instr/individual/fnegd.c | 7 + test/kvx/instr/individual/fnegw.c | 7 + test/kvx/instr/individual/for.c | 9 + test/kvx/instr/individual/forvar.c | 9 + test/kvx/instr/individual/forvarl.c | 10 + test/kvx/instr/individual/fsbfd.c | 7 + test/kvx/instr/individual/fsbfw.c | 7 + test/kvx/instr/individual/indirect_call.c | 33 +++ test/kvx/instr/individual/indirect_tailcall.c | 33 +++ test/kvx/instr/individual/lbs.c | 9 + test/kvx/instr/individual/lbz.c | 9 + test/kvx/instr/individual/muld.c | 7 + test/kvx/instr/individual/mulw.c | 7 + test/kvx/instr/individual/negd.c | 7 + test/kvx/instr/individual/ord.c | 7 + test/kvx/instr/individual/sbfd.c | 7 + test/kvx/instr/individual/sbfw.c | 7 + test/kvx/instr/individual/simple.c | 7 + test/kvx/instr/individual/sllw.c | 7 + test/kvx/instr/individual/srad.c | 7 + test/kvx/instr/individual/srld.c | 7 + test/kvx/instr/individual/tailcall.c | 16 ++ test/kvx/instr/individual/udivd.c | 7 + test/kvx/instr/individual/umodd.c | 7 + test/kvx/instr/individual/xord.c | 7 + test/kvx/instr/modi32.c | 5 + test/kvx/instr/modui32.c | 7 + test/kvx/instr/ui32.c | 12 + test/kvx/instr/ui64.c | 10 + test/kvx/interop/.gitignore | 1 + test/kvx/interop/Makefile | 365 +++++++++++++++++++++++ test/kvx/interop/common.c | 257 +++++++++++++++++ test/kvx/interop/common.h | 28 ++ test/kvx/interop/framework.h | 66 +++++ test/kvx/interop/i32.c | 13 + test/kvx/interop/i64.c | 14 + test/kvx/interop/individual/i_multiiargs.c | 6 + test/kvx/interop/individual/i_oneiarg.c | 6 + test/kvx/interop/individual/ll_multillargs.c | 7 + test/kvx/interop/individual/ll_onellarg.c | 7 + test/kvx/interop/individual/ll_void.c | 7 + test/kvx/interop/individual/void_void.c | 7 + test/kvx/interop/stackhell.c | 9 + test/kvx/interop/vaarg_common.c | 383 +++++++++++++++++++++++++ test/kvx/lib/Makefile | 133 +++++++++ test/kvx/lib/printf-test.c | 9 + test/kvx/lib/printf.c | 9 + test/kvx/mmult/.gitignore | 4 + test/kvx/mmult/Makefile | 67 +++++ test/kvx/mmult/README.md | 17 ++ test/kvx/mmult/mmult.c | 146 ++++++++++ test/kvx/mmult/mmult.h | 10 + test/kvx/prng/.gitignore | 3 + test/kvx/prng/Makefile | 69 +++++ test/kvx/prng/README.md | 17 ++ test/kvx/prng/prng.c | 41 +++ test/kvx/prng/prng.h | 10 + test/kvx/prng/types.h | 7 + test/kvx/simucheck.sh | 8 + test/kvx/simutest.sh | 8 + test/kvx/sort/.gitignore | 9 + test/kvx/sort/Makefile | 91 ++++++ test/kvx/sort/README.md | 17 ++ test/kvx/sort/insertion.c | 59 ++++ test/kvx/sort/insertion.h | 6 + test/kvx/sort/main.c | 34 +++ test/kvx/sort/merge.c | 92 ++++++ test/kvx/sort/merge.h | 7 + test/kvx/sort/selection.c | 62 ++++ test/kvx/sort/selection.h | 6 + test/kvx/sort/test.h | 6 + test/mppa/.gitignore | 20 -- test/mppa/builtins/clzll.c | 7 - test/mppa/builtins/stsud.c | 7 - test/mppa/coverage.sh | 24 -- test/mppa/coverage_helper.py | 45 --- test/mppa/delout.sh | 6 - test/mppa/do_test.sh | 50 ---- test/mppa/general/clzd.c | 7 - test/mppa/general/clzw.c | 7 - test/mppa/general/ctzd.c | 7 - test/mppa/general/ctzw.c | 7 - test/mppa/general/satd.c | 7 - test/mppa/general/sbmm8.c | 7 - test/mppa/general/sbmmt8.c | 7 - test/mppa/hardcheck.sh | 6 - test/mppa/hardtest.sh | 6 - test/mppa/instr/.gitignore | 1 - test/mppa/instr/Makefile | 176 ------------ test/mppa/instr/builtin32.c | 12 - test/mppa/instr/builtin64.c | 17 -- test/mppa/instr/div32.c | 5 - test/mppa/instr/divf32.c | 5 - test/mppa/instr/divf64.c | 5 - test/mppa/instr/divu32.c | 7 - test/mppa/instr/f32.c | 8 - test/mppa/instr/f64.c | 8 - test/mppa/instr/floatcmp.py | 93 ------ test/mppa/instr/framework.h | 66 ----- test/mppa/instr/i32.c | 149 ---------- test/mppa/instr/i64.c | 169 ----------- test/mppa/instr/individual/andw.c | 5 - test/mppa/instr/individual/branch.c | 10 - test/mppa/instr/individual/branchz.c | 10 - test/mppa/instr/individual/branchzu.c | 11 - test/mppa/instr/individual/call.c | 16 -- test/mppa/instr/individual/cast_S32_S64.c | 7 - test/mppa/instr/individual/cast_S64_U32.c | 7 - test/mppa/instr/individual/cb.deqz.c | 10 - test/mppa/instr/individual/cb.dgez.c | 10 - test/mppa/instr/individual/cb.dgtz.c | 10 - test/mppa/instr/individual/cb.dlez.c | 10 - test/mppa/instr/individual/cb.dltz.c | 10 - test/mppa/instr/individual/cb.dnez.c | 10 - test/mppa/instr/individual/cb.wgez.c | 10 - test/mppa/instr/individual/cb.wgtz.c | 10 - test/mppa/instr/individual/cb.wlez.c | 10 - test/mppa/instr/individual/cb.wltz.c | 10 - test/mppa/instr/individual/compd.eq.c | 7 - test/mppa/instr/individual/compd.geu.c | 7 - test/mppa/instr/individual/compd.gt.c | 7 - test/mppa/instr/individual/compd.le.c | 7 - test/mppa/instr/individual/compd.leu.c | 7 - test/mppa/instr/individual/compd.lt.c | 7 - test/mppa/instr/individual/compd.ltu.c | 7 - test/mppa/instr/individual/compd.ne.c | 7 - test/mppa/instr/individual/compw.eq.c | 7 - test/mppa/instr/individual/compw.geu.c | 7 - test/mppa/instr/individual/compw.gt.c | 7 - test/mppa/instr/individual/compw.gtu.c | 7 - test/mppa/instr/individual/compw.le.c | 7 - test/mppa/instr/individual/compw.leu.c | 7 - test/mppa/instr/individual/compw.lt.c | 7 - test/mppa/instr/individual/compw.ltu.c | 7 - test/mppa/instr/individual/compw.ne.c | 7 - test/mppa/instr/individual/div2.c | 7 - test/mppa/instr/individual/doubleconv.c | 9 - test/mppa/instr/individual/floatconv.c | 9 - test/mppa/instr/individual/fmuld.c | 7 - test/mppa/instr/individual/fmulw.c | 7 - test/mppa/instr/individual/fnegd.c | 7 - test/mppa/instr/individual/fnegw.c | 7 - test/mppa/instr/individual/for.c | 9 - test/mppa/instr/individual/forvar.c | 9 - test/mppa/instr/individual/forvarl.c | 10 - test/mppa/instr/individual/fsbfd.c | 7 - test/mppa/instr/individual/fsbfw.c | 7 - test/mppa/instr/individual/indirect_call.c | 33 --- test/mppa/instr/individual/indirect_tailcall.c | 33 --- test/mppa/instr/individual/lbs.c | 9 - test/mppa/instr/individual/lbz.c | 9 - test/mppa/instr/individual/muld.c | 7 - test/mppa/instr/individual/mulw.c | 7 - test/mppa/instr/individual/negd.c | 7 - test/mppa/instr/individual/ord.c | 7 - test/mppa/instr/individual/sbfd.c | 7 - test/mppa/instr/individual/sbfw.c | 7 - test/mppa/instr/individual/simple.c | 7 - test/mppa/instr/individual/sllw.c | 7 - test/mppa/instr/individual/srad.c | 7 - test/mppa/instr/individual/srld.c | 7 - test/mppa/instr/individual/tailcall.c | 16 -- test/mppa/instr/individual/udivd.c | 7 - test/mppa/instr/individual/umodd.c | 7 - test/mppa/instr/individual/xord.c | 7 - test/mppa/instr/modi32.c | 5 - test/mppa/instr/modui32.c | 7 - test/mppa/instr/ui32.c | 12 - test/mppa/instr/ui64.c | 10 - test/mppa/interop/.gitignore | 1 - test/mppa/interop/Makefile | 365 ----------------------- test/mppa/interop/common.c | 257 ----------------- test/mppa/interop/common.h | 28 -- test/mppa/interop/framework.h | 66 ----- test/mppa/interop/i32.c | 13 - test/mppa/interop/i64.c | 14 - test/mppa/interop/individual/i_multiiargs.c | 6 - test/mppa/interop/individual/i_oneiarg.c | 6 - test/mppa/interop/individual/ll_multillargs.c | 7 - test/mppa/interop/individual/ll_onellarg.c | 7 - test/mppa/interop/individual/ll_void.c | 7 - test/mppa/interop/individual/void_void.c | 7 - test/mppa/interop/stackhell.c | 9 - test/mppa/interop/vaarg_common.c | 383 ------------------------- test/mppa/lib/Makefile | 133 --------- test/mppa/lib/printf-test.c | 9 - test/mppa/lib/printf.c | 9 - test/mppa/mmult/.gitignore | 4 - test/mppa/mmult/Makefile | 67 ----- test/mppa/mmult/README.md | 17 -- test/mppa/mmult/mmult.c | 146 ---------- test/mppa/mmult/mmult.h | 10 - test/mppa/prng/.gitignore | 3 - test/mppa/prng/Makefile | 69 ----- test/mppa/prng/README.md | 17 -- test/mppa/prng/prng.c | 41 --- test/mppa/prng/prng.h | 10 - test/mppa/prng/types.h | 7 - test/mppa/simucheck.sh | 8 - test/mppa/simutest.sh | 8 - test/mppa/sort/.gitignore | 9 - test/mppa/sort/Makefile | 91 ------ test/mppa/sort/README.md | 17 -- test/mppa/sort/insertion.c | 59 ---- test/mppa/sort/insertion.h | 6 - test/mppa/sort/main.c | 34 --- test/mppa/sort/merge.c | 92 ------ test/mppa/sort/merge.h | 7 - test/mppa/sort/selection.c | 62 ---- test/mppa/sort/selection.h | 6 - test/mppa/sort/test.h | 6 - test/regression/builtins-kvx.c | 72 +++++ test/regression/builtins-mppa_k1c.c | 72 ----- 320 files changed, 3822 insertions(+), 3822 deletions(-) create mode 100644 test/c/Results/binarytrees-kvx delete mode 100644 test/c/Results/binarytrees-mppa_k1c create mode 100644 test/c/Results/chomp-kvx delete mode 100644 test/c/Results/chomp-mppa_k1c create mode 100644 test/c/Results/fannkuch-kvx delete mode 100644 test/c/Results/fannkuch-mppa_k1c create mode 100644 test/c/Results/fft-kvx delete mode 100644 test/c/Results/fft-mppa_k1c create mode 100644 test/c/Results/fftsp-kvx delete mode 100644 test/c/Results/fftsp-mppa_k1c create mode 100644 test/c/Results/fftw-kvx delete mode 100644 test/c/Results/fftw-mppa_k1c create mode 100644 test/c/Results/fib-kvx delete mode 100644 test/c/Results/fib-mppa_k1c create mode 100644 test/c/Results/integr-kvx delete mode 100644 test/c/Results/integr-mppa_k1c create mode 100644 test/c/Results/knucleotide-kvx delete mode 100644 test/c/Results/knucleotide-mppa_k1c create mode 100644 test/c/Results/lists-kvx delete mode 100644 test/c/Results/lists-mppa_k1c create mode 100644 test/c/Results/mandelbrot-kvx delete mode 100644 test/c/Results/mandelbrot-mppa_k1c create mode 100644 test/c/Results/nbody-kvx delete mode 100644 test/c/Results/nbody-mppa_k1c create mode 100644 test/c/Results/nsieve-kvx delete mode 100644 test/c/Results/nsieve-mppa_k1c create mode 100644 test/c/Results/nsievebits-kvx delete mode 100644 test/c/Results/nsievebits-mppa_k1c create mode 100644 test/c/Results/perlin-kvx delete mode 100644 test/c/Results/perlin-mppa_k1c create mode 100644 test/c/Results/qsort-kvx delete mode 100644 test/c/Results/qsort-mppa_k1c create mode 100644 test/c/Results/sha1-kvx delete mode 100644 test/c/Results/sha1-mppa_k1c create mode 100644 test/c/Results/spectral-kvx delete mode 100644 test/c/Results/spectral-mppa_k1c create mode 100644 test/c/Results/vmach-kvx delete mode 100644 test/c/Results/vmach-mppa_k1c create mode 100644 test/kvx/.gitignore create mode 100644 test/kvx/builtins/clzll.c create mode 100644 test/kvx/builtins/stsud.c create mode 100755 test/kvx/coverage.sh create mode 100644 test/kvx/coverage_helper.py create mode 100755 test/kvx/delout.sh create mode 100644 test/kvx/do_test.sh create mode 100644 test/kvx/general/clzd.c create mode 100644 test/kvx/general/clzw.c create mode 100644 test/kvx/general/ctzd.c create mode 100644 test/kvx/general/ctzw.c create mode 100644 test/kvx/general/satd.c create mode 100644 test/kvx/general/sbmm8.c create mode 100644 test/kvx/general/sbmmt8.c create mode 100755 test/kvx/hardcheck.sh create mode 100755 test/kvx/hardtest.sh create mode 100644 test/kvx/instr/.gitignore create mode 100644 test/kvx/instr/Makefile create mode 100644 test/kvx/instr/builtin32.c create mode 100644 test/kvx/instr/builtin64.c create mode 100644 test/kvx/instr/div32.c create mode 100644 test/kvx/instr/divf32.c create mode 100644 test/kvx/instr/divf64.c create mode 100644 test/kvx/instr/divu32.c create mode 100644 test/kvx/instr/f32.c create mode 100644 test/kvx/instr/f64.c create mode 100755 test/kvx/instr/floatcmp.py create mode 100644 test/kvx/instr/framework.h create mode 100644 test/kvx/instr/i32.c create mode 100644 test/kvx/instr/i64.c create mode 100644 test/kvx/instr/individual/andw.c create mode 100644 test/kvx/instr/individual/branch.c create mode 100644 test/kvx/instr/individual/branchz.c create mode 100644 test/kvx/instr/individual/branchzu.c create mode 100644 test/kvx/instr/individual/call.c create mode 100644 test/kvx/instr/individual/cast_S32_S64.c create mode 100644 test/kvx/instr/individual/cast_S64_U32.c create mode 100644 test/kvx/instr/individual/cb.deqz.c create mode 100644 test/kvx/instr/individual/cb.dgez.c create mode 100644 test/kvx/instr/individual/cb.dgtz.c create mode 100644 test/kvx/instr/individual/cb.dlez.c create mode 100644 test/kvx/instr/individual/cb.dltz.c create mode 100644 test/kvx/instr/individual/cb.dnez.c create mode 100644 test/kvx/instr/individual/cb.wgez.c create mode 100644 test/kvx/instr/individual/cb.wgtz.c create mode 100644 test/kvx/instr/individual/cb.wlez.c create mode 100644 test/kvx/instr/individual/cb.wltz.c create mode 100644 test/kvx/instr/individual/compd.eq.c create mode 100644 test/kvx/instr/individual/compd.geu.c create mode 100644 test/kvx/instr/individual/compd.gt.c create mode 100644 test/kvx/instr/individual/compd.le.c create mode 100644 test/kvx/instr/individual/compd.leu.c create mode 100644 test/kvx/instr/individual/compd.lt.c create mode 100644 test/kvx/instr/individual/compd.ltu.c create mode 100644 test/kvx/instr/individual/compd.ne.c create mode 100644 test/kvx/instr/individual/compw.eq.c create mode 100644 test/kvx/instr/individual/compw.geu.c create mode 100644 test/kvx/instr/individual/compw.gt.c create mode 100644 test/kvx/instr/individual/compw.gtu.c create mode 100644 test/kvx/instr/individual/compw.le.c create mode 100644 test/kvx/instr/individual/compw.leu.c create mode 100644 test/kvx/instr/individual/compw.lt.c create mode 100644 test/kvx/instr/individual/compw.ltu.c create mode 100644 test/kvx/instr/individual/compw.ne.c create mode 100644 test/kvx/instr/individual/div2.c create mode 100644 test/kvx/instr/individual/doubleconv.c create mode 100644 test/kvx/instr/individual/floatconv.c create mode 100644 test/kvx/instr/individual/fmuld.c create mode 100644 test/kvx/instr/individual/fmulw.c create mode 100644 test/kvx/instr/individual/fnegd.c create mode 100644 test/kvx/instr/individual/fnegw.c create mode 100644 test/kvx/instr/individual/for.c create mode 100644 test/kvx/instr/individual/forvar.c create mode 100644 test/kvx/instr/individual/forvarl.c create mode 100644 test/kvx/instr/individual/fsbfd.c create mode 100644 test/kvx/instr/individual/fsbfw.c create mode 100644 test/kvx/instr/individual/indirect_call.c create mode 100644 test/kvx/instr/individual/indirect_tailcall.c create mode 100644 test/kvx/instr/individual/lbs.c create mode 100644 test/kvx/instr/individual/lbz.c create mode 100644 test/kvx/instr/individual/muld.c create mode 100644 test/kvx/instr/individual/mulw.c create mode 100644 test/kvx/instr/individual/negd.c create mode 100644 test/kvx/instr/individual/ord.c create mode 100644 test/kvx/instr/individual/sbfd.c create mode 100644 test/kvx/instr/individual/sbfw.c create mode 100644 test/kvx/instr/individual/simple.c create mode 100644 test/kvx/instr/individual/sllw.c create mode 100644 test/kvx/instr/individual/srad.c create mode 100644 test/kvx/instr/individual/srld.c create mode 100644 test/kvx/instr/individual/tailcall.c create mode 100644 test/kvx/instr/individual/udivd.c create mode 100644 test/kvx/instr/individual/umodd.c create mode 100644 test/kvx/instr/individual/xord.c create mode 100644 test/kvx/instr/modi32.c create mode 100644 test/kvx/instr/modui32.c create mode 100644 test/kvx/instr/ui32.c create mode 100644 test/kvx/instr/ui64.c create mode 100644 test/kvx/interop/.gitignore create mode 100644 test/kvx/interop/Makefile create mode 100644 test/kvx/interop/common.c create mode 100644 test/kvx/interop/common.h create mode 100644 test/kvx/interop/framework.h create mode 100644 test/kvx/interop/i32.c create mode 100644 test/kvx/interop/i64.c create mode 100644 test/kvx/interop/individual/i_multiiargs.c create mode 100644 test/kvx/interop/individual/i_oneiarg.c create mode 100644 test/kvx/interop/individual/ll_multillargs.c create mode 100644 test/kvx/interop/individual/ll_onellarg.c create mode 100644 test/kvx/interop/individual/ll_void.c create mode 100644 test/kvx/interop/individual/void_void.c create mode 100644 test/kvx/interop/stackhell.c create mode 100644 test/kvx/interop/vaarg_common.c create mode 100644 test/kvx/lib/Makefile create mode 100644 test/kvx/lib/printf-test.c create mode 100644 test/kvx/lib/printf.c create mode 100644 test/kvx/mmult/.gitignore create mode 100644 test/kvx/mmult/Makefile create mode 100644 test/kvx/mmult/README.md create mode 100644 test/kvx/mmult/mmult.c create mode 100644 test/kvx/mmult/mmult.h create mode 100644 test/kvx/prng/.gitignore create mode 100644 test/kvx/prng/Makefile create mode 100644 test/kvx/prng/README.md create mode 100644 test/kvx/prng/prng.c create mode 100644 test/kvx/prng/prng.h create mode 100644 test/kvx/prng/types.h create mode 100755 test/kvx/simucheck.sh create mode 100755 test/kvx/simutest.sh create mode 100644 test/kvx/sort/.gitignore create mode 100644 test/kvx/sort/Makefile create mode 100644 test/kvx/sort/README.md create mode 100644 test/kvx/sort/insertion.c create mode 100644 test/kvx/sort/insertion.h create mode 100644 test/kvx/sort/main.c create mode 100644 test/kvx/sort/merge.c create mode 100644 test/kvx/sort/merge.h create mode 100644 test/kvx/sort/selection.c create mode 100644 test/kvx/sort/selection.h create mode 100644 test/kvx/sort/test.h delete mode 100644 test/mppa/.gitignore delete mode 100644 test/mppa/builtins/clzll.c delete mode 100644 test/mppa/builtins/stsud.c delete mode 100755 test/mppa/coverage.sh delete mode 100644 test/mppa/coverage_helper.py delete mode 100755 test/mppa/delout.sh delete mode 100644 test/mppa/do_test.sh delete mode 100644 test/mppa/general/clzd.c delete mode 100644 test/mppa/general/clzw.c delete mode 100644 test/mppa/general/ctzd.c delete mode 100644 test/mppa/general/ctzw.c delete mode 100644 test/mppa/general/satd.c delete mode 100644 test/mppa/general/sbmm8.c delete mode 100644 test/mppa/general/sbmmt8.c delete mode 100755 test/mppa/hardcheck.sh delete mode 100755 test/mppa/hardtest.sh delete mode 100644 test/mppa/instr/.gitignore delete mode 100644 test/mppa/instr/Makefile delete mode 100644 test/mppa/instr/builtin32.c delete mode 100644 test/mppa/instr/builtin64.c delete mode 100644 test/mppa/instr/div32.c delete mode 100644 test/mppa/instr/divf32.c delete mode 100644 test/mppa/instr/divf64.c delete mode 100644 test/mppa/instr/divu32.c delete mode 100644 test/mppa/instr/f32.c delete mode 100644 test/mppa/instr/f64.c delete mode 100755 test/mppa/instr/floatcmp.py delete mode 100644 test/mppa/instr/framework.h delete mode 100644 test/mppa/instr/i32.c delete mode 100644 test/mppa/instr/i64.c delete mode 100644 test/mppa/instr/individual/andw.c delete mode 100644 test/mppa/instr/individual/branch.c delete mode 100644 test/mppa/instr/individual/branchz.c delete mode 100644 test/mppa/instr/individual/branchzu.c delete mode 100644 test/mppa/instr/individual/call.c delete mode 100644 test/mppa/instr/individual/cast_S32_S64.c delete mode 100644 test/mppa/instr/individual/cast_S64_U32.c delete mode 100644 test/mppa/instr/individual/cb.deqz.c delete mode 100644 test/mppa/instr/individual/cb.dgez.c delete mode 100644 test/mppa/instr/individual/cb.dgtz.c delete mode 100644 test/mppa/instr/individual/cb.dlez.c delete mode 100644 test/mppa/instr/individual/cb.dltz.c delete mode 100644 test/mppa/instr/individual/cb.dnez.c delete mode 100644 test/mppa/instr/individual/cb.wgez.c delete mode 100644 test/mppa/instr/individual/cb.wgtz.c delete mode 100644 test/mppa/instr/individual/cb.wlez.c delete mode 100644 test/mppa/instr/individual/cb.wltz.c delete mode 100644 test/mppa/instr/individual/compd.eq.c delete mode 100644 test/mppa/instr/individual/compd.geu.c delete mode 100644 test/mppa/instr/individual/compd.gt.c delete mode 100644 test/mppa/instr/individual/compd.le.c delete mode 100644 test/mppa/instr/individual/compd.leu.c delete mode 100644 test/mppa/instr/individual/compd.lt.c delete mode 100644 test/mppa/instr/individual/compd.ltu.c delete mode 100644 test/mppa/instr/individual/compd.ne.c delete mode 100644 test/mppa/instr/individual/compw.eq.c delete mode 100644 test/mppa/instr/individual/compw.geu.c delete mode 100644 test/mppa/instr/individual/compw.gt.c delete mode 100644 test/mppa/instr/individual/compw.gtu.c delete mode 100644 test/mppa/instr/individual/compw.le.c delete mode 100644 test/mppa/instr/individual/compw.leu.c delete mode 100644 test/mppa/instr/individual/compw.lt.c delete mode 100644 test/mppa/instr/individual/compw.ltu.c delete mode 100644 test/mppa/instr/individual/compw.ne.c delete mode 100644 test/mppa/instr/individual/div2.c delete mode 100644 test/mppa/instr/individual/doubleconv.c delete mode 100644 test/mppa/instr/individual/floatconv.c delete mode 100644 test/mppa/instr/individual/fmuld.c delete mode 100644 test/mppa/instr/individual/fmulw.c delete mode 100644 test/mppa/instr/individual/fnegd.c delete mode 100644 test/mppa/instr/individual/fnegw.c delete mode 100644 test/mppa/instr/individual/for.c delete mode 100644 test/mppa/instr/individual/forvar.c delete mode 100644 test/mppa/instr/individual/forvarl.c delete mode 100644 test/mppa/instr/individual/fsbfd.c delete mode 100644 test/mppa/instr/individual/fsbfw.c delete mode 100644 test/mppa/instr/individual/indirect_call.c delete mode 100644 test/mppa/instr/individual/indirect_tailcall.c delete mode 100644 test/mppa/instr/individual/lbs.c delete mode 100644 test/mppa/instr/individual/lbz.c delete mode 100644 test/mppa/instr/individual/muld.c delete mode 100644 test/mppa/instr/individual/mulw.c delete mode 100644 test/mppa/instr/individual/negd.c delete mode 100644 test/mppa/instr/individual/ord.c delete mode 100644 test/mppa/instr/individual/sbfd.c delete mode 100644 test/mppa/instr/individual/sbfw.c delete mode 100644 test/mppa/instr/individual/simple.c delete mode 100644 test/mppa/instr/individual/sllw.c delete mode 100644 test/mppa/instr/individual/srad.c delete mode 100644 test/mppa/instr/individual/srld.c delete mode 100644 test/mppa/instr/individual/tailcall.c delete mode 100644 test/mppa/instr/individual/udivd.c delete mode 100644 test/mppa/instr/individual/umodd.c delete mode 100644 test/mppa/instr/individual/xord.c delete mode 100644 test/mppa/instr/modi32.c delete mode 100644 test/mppa/instr/modui32.c delete mode 100644 test/mppa/instr/ui32.c delete mode 100644 test/mppa/instr/ui64.c delete mode 100644 test/mppa/interop/.gitignore delete mode 100644 test/mppa/interop/Makefile delete mode 100644 test/mppa/interop/common.c delete mode 100644 test/mppa/interop/common.h delete mode 100644 test/mppa/interop/framework.h delete mode 100644 test/mppa/interop/i32.c delete mode 100644 test/mppa/interop/i64.c delete mode 100644 test/mppa/interop/individual/i_multiiargs.c delete mode 100644 test/mppa/interop/individual/i_oneiarg.c delete mode 100644 test/mppa/interop/individual/ll_multillargs.c delete mode 100644 test/mppa/interop/individual/ll_onellarg.c delete mode 100644 test/mppa/interop/individual/ll_void.c delete mode 100644 test/mppa/interop/individual/void_void.c delete mode 100644 test/mppa/interop/stackhell.c delete mode 100644 test/mppa/interop/vaarg_common.c delete mode 100644 test/mppa/lib/Makefile delete mode 100644 test/mppa/lib/printf-test.c delete mode 100644 test/mppa/lib/printf.c delete mode 100644 test/mppa/mmult/.gitignore delete mode 100644 test/mppa/mmult/Makefile delete mode 100644 test/mppa/mmult/README.md delete mode 100644 test/mppa/mmult/mmult.c delete mode 100644 test/mppa/mmult/mmult.h delete mode 100644 test/mppa/prng/.gitignore delete mode 100644 test/mppa/prng/Makefile delete mode 100644 test/mppa/prng/README.md delete mode 100644 test/mppa/prng/prng.c delete mode 100644 test/mppa/prng/prng.h delete mode 100644 test/mppa/prng/types.h delete mode 100755 test/mppa/simucheck.sh delete mode 100755 test/mppa/simutest.sh delete mode 100644 test/mppa/sort/.gitignore delete mode 100644 test/mppa/sort/Makefile delete mode 100644 test/mppa/sort/README.md delete mode 100644 test/mppa/sort/insertion.c delete mode 100644 test/mppa/sort/insertion.h delete mode 100644 test/mppa/sort/main.c delete mode 100644 test/mppa/sort/merge.c delete mode 100644 test/mppa/sort/merge.h delete mode 100644 test/mppa/sort/selection.c delete mode 100644 test/mppa/sort/selection.h delete mode 100644 test/mppa/sort/test.h create mode 100644 test/regression/builtins-kvx.c delete mode 100644 test/regression/builtins-mppa_k1c.c diff --git a/test/c/Results/binarytrees-kvx b/test/c/Results/binarytrees-kvx new file mode 100644 index 00000000..72654db9 --- /dev/null +++ b/test/c/Results/binarytrees-kvx @@ -0,0 +1,4 @@ +stretch tree of depth 7 check: -1 +128 trees of depth 4 check: -128 +32 trees of depth 6 check: -32 +long lived tree of depth 6 check: -1 diff --git a/test/c/Results/binarytrees-mppa_k1c b/test/c/Results/binarytrees-mppa_k1c deleted file mode 100644 index 72654db9..00000000 --- a/test/c/Results/binarytrees-mppa_k1c +++ /dev/null @@ -1,4 +0,0 @@ -stretch tree of depth 7 check: -1 -128 trees of depth 4 check: -128 -32 trees of depth 6 check: -32 -long lived tree of depth 6 check: -1 diff --git a/test/c/Results/chomp-kvx b/test/c/Results/chomp-kvx new file mode 100644 index 00000000..7898d32f --- /dev/null +++ b/test/c/Results/chomp-kvx @@ -0,0 +1,9 @@ +player 0 plays at (1,1) +player 1 plays at (3,0) +player 0 plays at (0,3) +player 1 plays at (2,0) +player 0 plays at (0,2) +player 1 plays at (1,0) +player 0 plays at (0,1) +player 1 plays at (0,0) +player 1 loses diff --git a/test/c/Results/chomp-mppa_k1c b/test/c/Results/chomp-mppa_k1c deleted file mode 100644 index 7898d32f..00000000 --- a/test/c/Results/chomp-mppa_k1c +++ /dev/null @@ -1,9 +0,0 @@ -player 0 plays at (1,1) -player 1 plays at (3,0) -player 0 plays at (0,3) -player 1 plays at (2,0) -player 0 plays at (0,2) -player 1 plays at (1,0) -player 0 plays at (0,1) -player 1 plays at (0,0) -player 1 loses diff --git a/test/c/Results/fannkuch-kvx b/test/c/Results/fannkuch-kvx new file mode 100644 index 00000000..09ecc715 --- /dev/null +++ b/test/c/Results/fannkuch-kvx @@ -0,0 +1,31 @@ +123456 +213456 +231456 +321456 +312456 +132456 +234156 +324156 +342156 +432156 +423156 +243156 +341256 +431256 +413256 +143256 +134256 +314256 +412356 +142356 +124356 +214356 +241356 +421356 +234516 +324516 +342516 +432516 +423516 +243516 +Pfannkuchen(6) = 10 diff --git a/test/c/Results/fannkuch-mppa_k1c b/test/c/Results/fannkuch-mppa_k1c deleted file mode 100644 index 09ecc715..00000000 --- a/test/c/Results/fannkuch-mppa_k1c +++ /dev/null @@ -1,31 +0,0 @@ -123456 -213456 -231456 -321456 -312456 -132456 -234156 -324156 -342156 -432156 -423156 -243156 -341256 -431256 -413256 -143256 -134256 -314256 -412356 -142356 -124356 -214356 -241356 -421356 -234516 -324516 -342516 -432516 -423516 -243516 -Pfannkuchen(6) = 10 diff --git a/test/c/Results/fft-kvx b/test/c/Results/fft-kvx new file mode 100644 index 00000000..0fc1c969 --- /dev/null +++ b/test/c/Results/fft-kvx @@ -0,0 +1 @@ +1024 points, result OK diff --git a/test/c/Results/fft-mppa_k1c b/test/c/Results/fft-mppa_k1c deleted file mode 100644 index 0fc1c969..00000000 --- a/test/c/Results/fft-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -1024 points, result OK diff --git a/test/c/Results/fftsp-kvx b/test/c/Results/fftsp-kvx new file mode 100644 index 00000000..2b5711a6 --- /dev/null +++ b/test/c/Results/fftsp-kvx @@ -0,0 +1 @@ +8 points, result OK diff --git a/test/c/Results/fftsp-mppa_k1c b/test/c/Results/fftsp-mppa_k1c deleted file mode 100644 index 2b5711a6..00000000 --- a/test/c/Results/fftsp-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -8 points, result OK diff --git a/test/c/Results/fftw-kvx b/test/c/Results/fftw-kvx new file mode 100644 index 00000000..a1b6130c --- /dev/null +++ b/test/c/Results/fftw-kvx @@ -0,0 +1,16 @@ +o[0] = 2.918193e+01 +o[1] = -3.230611e+01 +o[2] = 1.271687e+01 +o[3] = -1.099040e+01 +o[4] = 5.728673e+00 +o[5] = -4.918940e+00 +o[6] = 1.880764e+00 +o[7] = -1.292782e+00 +o[8] = 1.104073e+02 +o[9] = -5.867858e+01 +o[10] = 2.768382e+01 +o[11] = -2.073843e+01 +o[12] = 1.229410e+01 +o[13] = -9.195029e+00 +o[14] = 4.307537e+00 +o[15] = -2.080713e+00 diff --git a/test/c/Results/fftw-mppa_k1c b/test/c/Results/fftw-mppa_k1c deleted file mode 100644 index a1b6130c..00000000 --- a/test/c/Results/fftw-mppa_k1c +++ /dev/null @@ -1,16 +0,0 @@ -o[0] = 2.918193e+01 -o[1] = -3.230611e+01 -o[2] = 1.271687e+01 -o[3] = -1.099040e+01 -o[4] = 5.728673e+00 -o[5] = -4.918940e+00 -o[6] = 1.880764e+00 -o[7] = -1.292782e+00 -o[8] = 1.104073e+02 -o[9] = -5.867858e+01 -o[10] = 2.768382e+01 -o[11] = -2.073843e+01 -o[12] = 1.229410e+01 -o[13] = -9.195029e+00 -o[14] = 4.307537e+00 -o[15] = -2.080713e+00 diff --git a/test/c/Results/fib-kvx b/test/c/Results/fib-kvx new file mode 100644 index 00000000..0e0fa4d1 --- /dev/null +++ b/test/c/Results/fib-kvx @@ -0,0 +1 @@ +fib(15) = 987 diff --git a/test/c/Results/fib-mppa_k1c b/test/c/Results/fib-mppa_k1c deleted file mode 100644 index 0e0fa4d1..00000000 --- a/test/c/Results/fib-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -fib(15) = 987 diff --git a/test/c/Results/integr-kvx b/test/c/Results/integr-kvx new file mode 100644 index 00000000..c61fdcc2 --- /dev/null +++ b/test/c/Results/integr-kvx @@ -0,0 +1 @@ +integr(square, 0.0, 1.0, 100000) = 0.333328 diff --git a/test/c/Results/integr-mppa_k1c b/test/c/Results/integr-mppa_k1c deleted file mode 100644 index c61fdcc2..00000000 --- a/test/c/Results/integr-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -integr(square, 0.0, 1.0, 100000) = 0.333328 diff --git a/test/c/Results/knucleotide-kvx b/test/c/Results/knucleotide-kvx new file mode 100644 index 00000000..e69de29b diff --git a/test/c/Results/knucleotide-mppa_k1c b/test/c/Results/knucleotide-mppa_k1c deleted file mode 100644 index e69de29b..00000000 diff --git a/test/c/Results/lists-kvx b/test/c/Results/lists-kvx new file mode 100644 index 00000000..2c94e483 --- /dev/null +++ b/test/c/Results/lists-kvx @@ -0,0 +1,2 @@ +OK +OK diff --git a/test/c/Results/lists-mppa_k1c b/test/c/Results/lists-mppa_k1c deleted file mode 100644 index 2c94e483..00000000 --- a/test/c/Results/lists-mppa_k1c +++ /dev/null @@ -1,2 +0,0 @@ -OK -OK diff --git a/test/c/Results/mandelbrot-kvx b/test/c/Results/mandelbrot-kvx new file mode 100644 index 00000000..55c5683a Binary files /dev/null and b/test/c/Results/mandelbrot-kvx differ diff --git a/test/c/Results/mandelbrot-mppa_k1c b/test/c/Results/mandelbrot-mppa_k1c deleted file mode 100644 index 55c5683a..00000000 Binary files a/test/c/Results/mandelbrot-mppa_k1c and /dev/null differ diff --git a/test/c/Results/nbody-kvx b/test/c/Results/nbody-kvx new file mode 100644 index 00000000..99ad4fd1 --- /dev/null +++ b/test/c/Results/nbody-kvx @@ -0,0 +1,2 @@ +-0.169075164 +-0.169050762 diff --git a/test/c/Results/nbody-mppa_k1c b/test/c/Results/nbody-mppa_k1c deleted file mode 100644 index 99ad4fd1..00000000 --- a/test/c/Results/nbody-mppa_k1c +++ /dev/null @@ -1,2 +0,0 @@ --0.169075164 --0.169050762 diff --git a/test/c/Results/nsieve-kvx b/test/c/Results/nsieve-kvx new file mode 100644 index 00000000..95fea812 --- /dev/null +++ b/test/c/Results/nsieve-kvx @@ -0,0 +1,3 @@ +Primes up to 12800 1526 +Primes up to 6400 834 +Primes up to 3200 452 diff --git a/test/c/Results/nsieve-mppa_k1c b/test/c/Results/nsieve-mppa_k1c deleted file mode 100644 index 95fea812..00000000 --- a/test/c/Results/nsieve-mppa_k1c +++ /dev/null @@ -1,3 +0,0 @@ -Primes up to 12800 1526 -Primes up to 6400 834 -Primes up to 3200 452 diff --git a/test/c/Results/nsievebits-kvx b/test/c/Results/nsievebits-kvx new file mode 100644 index 00000000..2131804c --- /dev/null +++ b/test/c/Results/nsievebits-kvx @@ -0,0 +1,3 @@ +Primes up to 40000 4203 +Primes up to 20000 2262 +Primes up to 10000 1229 diff --git a/test/c/Results/nsievebits-mppa_k1c b/test/c/Results/nsievebits-mppa_k1c deleted file mode 100644 index 2131804c..00000000 --- a/test/c/Results/nsievebits-mppa_k1c +++ /dev/null @@ -1,3 +0,0 @@ -Primes up to 40000 4203 -Primes up to 20000 2262 -Primes up to 10000 1229 diff --git a/test/c/Results/perlin-kvx b/test/c/Results/perlin-kvx new file mode 100644 index 00000000..8438b53c --- /dev/null +++ b/test/c/Results/perlin-kvx @@ -0,0 +1 @@ +6.0000e+00 diff --git a/test/c/Results/perlin-mppa_k1c b/test/c/Results/perlin-mppa_k1c deleted file mode 100644 index 8438b53c..00000000 --- a/test/c/Results/perlin-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -6.0000e+00 diff --git a/test/c/Results/qsort-kvx b/test/c/Results/qsort-kvx new file mode 100644 index 00000000..d86bac9d --- /dev/null +++ b/test/c/Results/qsort-kvx @@ -0,0 +1 @@ +OK diff --git a/test/c/Results/qsort-mppa_k1c b/test/c/Results/qsort-mppa_k1c deleted file mode 100644 index d86bac9d..00000000 --- a/test/c/Results/qsort-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -OK diff --git a/test/c/Results/sha1-kvx b/test/c/Results/sha1-kvx new file mode 100644 index 00000000..730d5406 --- /dev/null +++ b/test/c/Results/sha1-kvx @@ -0,0 +1,2 @@ +Test `abc': passed +Test `abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq': passed diff --git a/test/c/Results/sha1-mppa_k1c b/test/c/Results/sha1-mppa_k1c deleted file mode 100644 index 730d5406..00000000 --- a/test/c/Results/sha1-mppa_k1c +++ /dev/null @@ -1,2 +0,0 @@ -Test `abc': passed -Test `abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq': passed diff --git a/test/c/Results/spectral-kvx b/test/c/Results/spectral-kvx new file mode 100644 index 00000000..b06cd560 --- /dev/null +++ b/test/c/Results/spectral-kvx @@ -0,0 +1 @@ +1.272359925 diff --git a/test/c/Results/spectral-mppa_k1c b/test/c/Results/spectral-mppa_k1c deleted file mode 100644 index b06cd560..00000000 --- a/test/c/Results/spectral-mppa_k1c +++ /dev/null @@ -1 +0,0 @@ -1.272359925 diff --git a/test/c/Results/vmach-kvx b/test/c/Results/vmach-kvx new file mode 100644 index 00000000..a95237a6 --- /dev/null +++ b/test/c/Results/vmach-kvx @@ -0,0 +1,2 @@ +fib(15) = 987 +tak(12, 9, 6) = 9 diff --git a/test/c/Results/vmach-mppa_k1c b/test/c/Results/vmach-mppa_k1c deleted file mode 100644 index a95237a6..00000000 --- a/test/c/Results/vmach-mppa_k1c +++ /dev/null @@ -1,2 +0,0 @@ -fib(15) = 987 -tak(12, 9, 6) = 9 diff --git a/test/kvx/.gitignore b/test/kvx/.gitignore new file mode 100644 index 00000000..b10c40c8 --- /dev/null +++ b/test/kvx/.gitignore @@ -0,0 +1,20 @@ +check +asm_coverage +instr/Makefile +mmult/Makefile +prng/Makefile +sort/Makefile +prng/.zero +sort/.zero +sort/insertion-ccomp-kvx +sort/insertion-gcc-kvx +sort/insertion-gcc-x86 +sort/main-ccomp-kvx +sort/main-gcc-kvx +sort/main-gcc-x86 +sort/merge-ccomp-kvx +sort/merge-gcc-kvx +sort/merge-gcc-x86 +sort/selection-ccomp-kvx +sort/selection-gcc-kvx +sort/selection-gcc-x86 diff --git a/test/kvx/builtins/clzll.c b/test/kvx/builtins/clzll.c new file mode 100644 index 00000000..13905cba --- /dev/null +++ b/test/kvx/builtins/clzll.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = __builtin_clzll(a); +} +END_TEST() diff --git a/test/kvx/builtins/stsud.c b/test/kvx/builtins/stsud.c new file mode 100644 index 00000000..fa42b001 --- /dev/null +++ b/test/kvx/builtins/stsud.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_kvx_stsud(t[0], t[1]); +} +END_TEST() diff --git a/test/kvx/coverage.sh b/test/kvx/coverage.sh new file mode 100755 index 00000000..96f6bc04 --- /dev/null +++ b/test/kvx/coverage.sh @@ -0,0 +1,24 @@ +#!/bin/bash + +printer=../../kvx/TargetPrinter.ml +asmdir=instr/asm/ +to_cover_raw=/tmp/to_cover_raw +to_cover=/tmp/to_cover +covered_raw=/tmp/covered_raw +covered=/tmp/covered + +# Stop at any error +set -e +# Pipes do not mask errors +set -o pipefail + +sed -n "s/^.*fprintf\s\+oc\s*\"\s*\([a-z][^[:space:]]*\)\s.*/\1/p" $printer > $to_cover_raw +python2.7 coverage_helper.py $to_cover_raw | sort -u > $to_cover + +rm -f $covered_raw +for asm in $(ls $asmdir/*.ccomp.s); do + grep -v ":" $asm | sed -n "s/^\s*\([a-z][a-z0-9.]*\).*/\1/p" | sort -u >> $covered_raw +done +python2.7 coverage_helper.py $covered_raw | sort -u > $covered + +vimdiff $to_cover $covered diff --git a/test/kvx/coverage_helper.py b/test/kvx/coverage_helper.py new file mode 100644 index 00000000..e5b1907c --- /dev/null +++ b/test/kvx/coverage_helper.py @@ -0,0 +1,45 @@ +import fileinput +import sys + +all_loads_stores = "lbs lbz lhz lo lq ld lhs lws sb sd sh so sq sw".split(" ") + +all_bconds = "wnez weqz wltz wgez wlez wgtz dnez deqz dltz dgez dlez dgtz".split(" ") + +all_iconds = "ne eq lt ge le gt ltu geu leu gtu".split(" ") + +all_fconds = "one ueq oeq une olt uge oge ult".split(" ") + +replaces_a = [(["cb.", "cmoved."], all_bconds), + (["compd.", "compw."], all_iconds), + (["fcompd.", "fcompw."], all_fconds), + (all_loads_stores, [".xs", ""])] + +replaces_dd = [(["addx", "sbfx"], ["2d", "4d", "8d", "16d"])] +replaces_dw = [(["addx", "sbfx"], ["2w", "4w", "8w", "16w"])] + +macros_binds = {"%a": replaces_a, "%dd": replaces_dd, "%dw": replaces_dw} + +def expand_macro(fullinst, macro, replaceTable): + inst = fullinst.replace(macro, "") + for (searchlist, mods) in replaceTable: + if inst in searchlist: + return [fullinst.replace(macro, mod) for mod in mods] + raise NameError + +insts = [] +for line in fileinput.input(): + fullinst = line[:-1] + try: + for macro in macros_binds: + if macro in fullinst: + insts.extend(expand_macro(fullinst, macro, macros_binds[macro])) + break + else: + insts.append(fullinst) + except NameError: + print >> sys.stderr, fullinst + " could not be found any match for macro " + macro + sys.exit(1) + +for inst in insts: + print inst +occurs = {} diff --git a/test/kvx/delout.sh b/test/kvx/delout.sh new file mode 100755 index 00000000..e9c72e1c --- /dev/null +++ b/test/kvx/delout.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +for folder in prng mmult sort instr interop; do + rm -f $folder/*.out + rm -f $folder/out/* +done diff --git a/test/kvx/do_test.sh b/test/kvx/do_test.sh new file mode 100644 index 00000000..5cc23dee --- /dev/null +++ b/test/kvx/do_test.sh @@ -0,0 +1,50 @@ +do_test () { +cat << EOF + +## +# PRNG tests +## +EOF +(cd prng && make $1 -j$2) + +cat << EOF + +## +# Matrix Multiplication tests +## +EOF +(cd mmult && make $1 -j$2) + +cat << EOF + +## +# List sort tests +## +EOF +(cd sort && make $1 -j$2) + +cat << EOF + +## +# Instruction unit tests +## +EOF +(cd instr && make $1 -j$2) + +cat << EOF + +## +# Interoperability with GCC +## +EOF +(cd interop && make $1 -j$2) + +cat << EOF + +## +# printf wrapper test +## +(cd lib && make $1 -j$2) +EOF + +} diff --git a/test/kvx/general/clzd.c b/test/kvx/general/clzd.c new file mode 100644 index 00000000..d3e8a8ec --- /dev/null +++ b/test/kvx/general/clzd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_kvx_clzd(t[0]); +} +END_TEST() diff --git a/test/kvx/general/clzw.c b/test/kvx/general/clzw.c new file mode 100644 index 00000000..7b5478fd --- /dev/null +++ b/test/kvx/general/clzw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_kvx_clzw(t[0]); +} +END_TEST() diff --git a/test/kvx/general/ctzd.c b/test/kvx/general/ctzd.c new file mode 100644 index 00000000..bba869e1 --- /dev/null +++ b/test/kvx/general/ctzd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_kvx_ctzd(t[0]); +} +END_TEST() diff --git a/test/kvx/general/ctzw.c b/test/kvx/general/ctzw.c new file mode 100644 index 00000000..a7128b04 --- /dev/null +++ b/test/kvx/general/ctzw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 1) +{ + c = __builtin_kvx_ctzw(t[0]); +} +END_TEST() diff --git a/test/kvx/general/satd.c b/test/kvx/general/satd.c new file mode 100644 index 00000000..9d0d1cf9 --- /dev/null +++ b/test/kvx/general/satd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_kvx_satd(t[0], t[1]); +} +END_TEST() diff --git a/test/kvx/general/sbmm8.c b/test/kvx/general/sbmm8.c new file mode 100644 index 00000000..91f13425 --- /dev/null +++ b/test/kvx/general/sbmm8.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_kvx_sbmm8(t[0], t[1]); +} +END_TEST() diff --git a/test/kvx/general/sbmmt8.c b/test/kvx/general/sbmmt8.c new file mode 100644 index 00000000..7b120dfa --- /dev/null +++ b/test/kvx/general/sbmmt8.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST_N(unsigned long long, 2) +{ + c = __builtin_kvx_sbmmt8(t[0], t[1]); +} +END_TEST() diff --git a/test/kvx/hardcheck.sh b/test/kvx/hardcheck.sh new file mode 100755 index 00000000..b6538f0e --- /dev/null +++ b/test/kvx/hardcheck.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the execution of the binaries produced by CompCert, in hardware + +source do_test.sh + +do_test hardcheck 1 diff --git a/test/kvx/hardtest.sh b/test/kvx/hardtest.sh new file mode 100755 index 00000000..6321bc7d --- /dev/null +++ b/test/kvx/hardtest.sh @@ -0,0 +1,6 @@ +#!/bin/bash +# Tests the validity of the tests, in hardware + +source do_test.sh + +do_test hardtest 1 diff --git a/test/kvx/instr/.gitignore b/test/kvx/instr/.gitignore new file mode 100644 index 00000000..ea1472ec --- /dev/null +++ b/test/kvx/instr/.gitignore @@ -0,0 +1 @@ +output/ diff --git a/test/kvx/instr/Makefile b/test/kvx/instr/Makefile new file mode 100644 index 00000000..e4f964b3 --- /dev/null +++ b/test/kvx/instr/Makefile @@ -0,0 +1,176 @@ +SHELL := /bin/bash + +KVXC ?= k1-cos-gcc +CC ?= gcc +CCOMP ?= ccomp +OPTIM ?= -O2 +CFLAGS ?= $(OPTIM) +CCOMPFLAGS ?= $(CFLAGS) +SIMU ?= k1-mppa +TIMEOUT ?= --signal=SIGTERM 120s +DIFF ?= python2.7 floatcmp.py -reltol .00001 +HARDRUN ?= k1-jtag-runner + +DIR=./ +SRCDIR=$(DIR) +OUTDIR=$(DIR)/out +BINDIR=$(DIR)/bin +ASMDIR=$(DIR)/asm +LIB=../lib/system.x86-gcc.a +K1LIB=../lib/system.gcc.a + +## +# Intended flow : .c -> .gcc.s -> .gcc.bin -> .gcc.out +# -> .ccomp.s -> .ccomp.bin -> .ccomp.out +## + +KVXCPATH=$(shell which $(KVXC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +TESTNAMES?=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))) +X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) +GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES))) +CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES))) +GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES))) +CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES))) + +BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES))) + +## +# Targets +## + +all: $(BIN) + +GREEN=\033[0;32m +RED=\033[0;31m +YELLOW=\033[0;33m +NC=\033[0m + +.PHONY: +test: simutest + +.PHONY: +check: simucheck + +.PHONY: +simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) + @echo "Comparing x86 gcc output to k1 gcc.." + for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.simu.out;\ + if grep "__KVX__" -q $$test.c; then\ + printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ + elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ + >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.simu.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\ + if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ + >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) + @echo "Comparing x86 gcc output to k1 gcc.." + for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.hard.out;\ + if grep "__KVX__" -q $$test.c; then\ + printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ + elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ + >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.hard.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\ + if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ + >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ + fi;\ + done + +## +# Rules +## + +.SECONDARY: +$(LIB): + (cd $(dir $(LIB)) && make) + +$(K1LIB): + (cd $(dir $(LIB)) && make) + +# Generating output + +## Version avec timeout +$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +# Assembly to binary + +$(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(LIB) $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1LIB) $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ + +$(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(K1LIB) $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CCOMPFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +# Source to assembly + +$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CCOMPFLAGS) -S $< -o $@ diff --git a/test/kvx/instr/builtin32.c b/test/kvx/instr/builtin32.c new file mode 100644 index 00000000..9efb33cd --- /dev/null +++ b/test/kvx/instr/builtin32.c @@ -0,0 +1,12 @@ +#include "framework.h" + +BEGIN_TEST(int) + int *ptr = &c; +#ifdef __KVX__ + int d = c; + a = __builtin_kvx_alclrw(ptr); + c = d; + +#endif +END_TEST32() + diff --git a/test/kvx/instr/builtin64.c b/test/kvx/instr/builtin64.c new file mode 100644 index 00000000..252eb2c6 --- /dev/null +++ b/test/kvx/instr/builtin64.c @@ -0,0 +1,17 @@ +#include "framework.h" + +BEGIN_TEST(long long) + long long *ptr = &c; +#ifdef __KVX__ + long long d = c; + a = __builtin_kvx_alclrd(ptr); + c = d; + c += a; + + c += __builtin_clzll(a); + + /* Removed the AFADDD builtin who was incorrect in CompCert, see #157 */ + // a = __builtin_kvx_afaddd(ptr, a); + // a = __builtin_kvx_afaddd(ptr, a); +#endif +END_TEST64() diff --git a/test/kvx/instr/div32.c b/test/kvx/instr/div32.c new file mode 100644 index 00000000..83c3a0e3 --- /dev/null +++ b/test/kvx/instr/div32.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(int) + c = a/b; +END_TEST32() diff --git a/test/kvx/instr/divf32.c b/test/kvx/instr/divf32.c new file mode 100644 index 00000000..513a3293 --- /dev/null +++ b/test/kvx/instr/divf32.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(float) + c = a / b; +END_TESTF32() diff --git a/test/kvx/instr/divf64.c b/test/kvx/instr/divf64.c new file mode 100644 index 00000000..0dd23826 --- /dev/null +++ b/test/kvx/instr/divf64.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(double) + c = a / b; +END_TESTF64() diff --git a/test/kvx/instr/divu32.c b/test/kvx/instr/divu32.c new file mode 100644 index 00000000..1fe196c4 --- /dev/null +++ b/test/kvx/instr/divu32.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = a/b; +} +END_TEST32() diff --git a/test/kvx/instr/f32.c b/test/kvx/instr/f32.c new file mode 100644 index 00000000..7e304aeb --- /dev/null +++ b/test/kvx/instr/f32.c @@ -0,0 +1,8 @@ +#include "framework.h" + +BEGIN_TEST(float) + c = ((float)a + (float)b); + c += ((float)a * (float)b); + c += (-(float)a); + c += ((float)a - (float)b); +END_TESTF32() diff --git a/test/kvx/instr/f64.c b/test/kvx/instr/f64.c new file mode 100644 index 00000000..be8094c9 --- /dev/null +++ b/test/kvx/instr/f64.c @@ -0,0 +1,8 @@ +#include "framework.h" + +BEGIN_TEST(double) + c = ((double)a + (double)b); + c += ((double)a * (double)b); + c += (-(double)a); + c += ((double)a - (double)b); +END_TESTF64() diff --git a/test/kvx/instr/floatcmp.py b/test/kvx/instr/floatcmp.py new file mode 100755 index 00000000..49f1bc13 --- /dev/null +++ b/test/kvx/instr/floatcmp.py @@ -0,0 +1,93 @@ +#!/usr/bin/python2.7 + +import argparse as ap +import sys + +parser = ap.ArgumentParser() +parser.add_argument("file1", help="First file to compare") +parser.add_argument("file2", help="Second file to compare") +parser.add_argument("-reltol", help="Relative error") +parser.add_argument("-abstol", help="Absolute error") +parser.add_argument("-s", help="Silent output", action="store_true") +args = parser.parse_args() + +reltol = float(args.reltol) if args.reltol else None +abstol = float(args.abstol) if args.abstol else None +silent = args.s + +if silent: + sys.stdout = open("/dev/null", "w") + +import re +from math import fabs + +def floatcmp(f1, f2): + if abstol: + if fabs(f1 - f2) > abstol: + return False + if reltol: + if f2 != 0. and fabs((f1 - f2) / f2) > reltol: + return False + return True + +class Parsed(list): + def __eq__(self, other): + if len(self) != len(other): + return False + comps = zip(self, other) + for comp in comps: + if all(isinstance(compElt, str) for compElt in comp): + if comp[0] != comp[1]: + return False + elif all (isinstance(compElt, float) for compElt in comp): + if not floatcmp(comp[0], comp[1]): + return False + else: + return False + return True + + def __ne__(self, other): + return not self.__eq__(other) + +parseLine = re.compile(r"\s*(\S+)") +def readline(line): + words = parseLine.findall(line) + parsed = Parsed([]) + for word in words: + try: + parse = float(word) + parsed.append(parse) + except ValueError: + parsed.append(word) + return parsed + +def readfile(filename): + L = [] + try: + with open(filename) as f: + for line in f: + L.append(readline(line)) + except IOError: + print "Unable to read {}".format(filename) + sys.exit(2) + return L + +L1 = readfile(args.file1) +L2 = readfile(args.file2) + +if len(L1) != len(L2): + print "The files have different amount of lines" + print "\t{}: {} lines".format(args.file1, len(L1)) + print "\t{}: {} lines".format(args.file2, len(L2)) + sys.exit(1) + +cmpL = zip(L1, L2) +for i, cmpElt in enumerate(cmpL): + if cmpElt[0] != cmpElt[1]: + print "The files differ at line {}".format(i) + print "\t{}: {}".format(args.file1, cmpElt[0]) + print "\t{}: {}".format(args.file2, cmpElt[1]) + sys.exit(1) + +print "Comparison succeeded" +sys.exit(0) diff --git a/test/kvx/instr/framework.h b/test/kvx/instr/framework.h new file mode 100644 index 00000000..3bbfa271 --- /dev/null +++ b/test/kvx/instr/framework.h @@ -0,0 +1,66 @@ +#ifndef __FRAMEWORK_H__ +#define __FRAMEWORK_H__ + +#include +#include "../prng/prng.c" + +#define BEGIN_TEST_N(type, N)\ + int main(void){\ + type t[N], c, i, j, S;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + for (j = 0 ; j < N ; j++)\ + t[j] = randlong();\ + /* END BEGIN_TEST_N */ + +#define BEGIN_TEST(type)\ + int main(void){\ + type a, b, c, S;\ + int i;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + a = randlong();\ + b = randlong(); + /* END BEGIN_TEST */ + +/* In between BEGIN_TEST and END_TEST : definition of c */ + +#define END_TEST64()\ + printf("%llu\t%llu\t%llu\n", a, b, c);\ + S += c;\ + }\ + return S;\ + } + /* END END_TEST64 */ + +#define END_TEST32()\ + printf("%u\t%u\t%u\n", a, b, c);\ + S += c;\ + }\ + return S;\ + } + /* END END_TEST32 */ + +#define END_TESTF32()\ + printf("%e\t%e\t%e\n", a, b, c);\ + S += c;\ + }\ + return 0;\ + } + /* END END_TESTF32 */ + +#define END_TESTF64()\ + printf("%e\t%e\t%e\n", a, b, c);\ + S += c;\ + }\ + return 0;\ + } + /* END END_TESTF64 */ + +#endif + + diff --git a/test/kvx/instr/i32.c b/test/kvx/instr/i32.c new file mode 100644 index 00000000..e350931c --- /dev/null +++ b/test/kvx/instr/i32.c @@ -0,0 +1,149 @@ +#include "framework.h" + +int sum(int a, int b){ + return a+b; +} + +int make(int a){ + return a; +} + +int tailsum(int a, int b){ + return make(a+b); +} + +int fact(int a){ + int r = 1; + int i; + for (i = 1; i < a; i++) + r *= i; + return r; +} + +float int2float(int v){ + return v; +} + +BEGIN_TEST(int) + c = a+b; + c += a&b; + + /* testing if, cb version */ + if ((a & 0x1) == 1) + c += fact(1); + else + c += fact(2); + + if (a & 0x1 == 0) + c += fact(4); + else + c += fact(8); + + if (a & 0x1 == 0) + c += fact(4); + else + c += fact(8); + + b = !(a & 0x01); + if (!b) + c += fact(16); + else + c += fact(32); + + c += sum(make(a), make(b)); + c += (long long) a; + + if (0 > (a & 0x1) - 1) + c += fact(64); + else + c += fact(128); + + if (0 >= (a & 0x1)) + c += fact(256); + else + c += fact(512); + + if ((a & 0x1) > 0) + c += fact(1024); + else + c += fact(2048); + + if ((a & 0x1) - 1 >= 0) + c += fact(4096); + else + c += fact(8192); + + /* cmoved version */ + if ((a & 0x1) == 1) + c += 1; + else + c += 2; + + if (a & 0x1 == 0) + c += 4; + else + c += 8; + + if (a & 0x1 == 0) + c += 4; + else + c += 8; + + b = !(a & 0x01); + if (!b) + c += 16; + else + c += 32; + + if (0 > (a & 0x1) - 1) + c += 64; + else + c += 128; + + if (0 >= (a & 0x1)) + c += 256; + else + c += 512; + + if ((a & 0x1) > 0) + c += 1024; + else + c += 2048; + + if ((a & 0x1) - 1 >= 0) + c += 4096; + else + c += 8192; + + c += ((a & 0x1) == (b & 0x1)); + c += (a > b); + c += (a <= b); + c += (a < b); + c += (a + b) / 2; + c += (int) int2float(a) + (int) int2float(b) + (int) int2float(42.3); + c += (a << 4); // addx16w + c += (a << 3); // addx8w + c += (a << 2); // addx4w + c += (a << 1); // addx2w + + c += ~a & b; // andnw + + int j; + for (j = 0 ; j < 10 ; j++) + c += a; + int k; + for (k = 0 ; k < (b & 0x8) ; k++) + c += a; + + char s[] = "Tome and Cherry at the playa\n"; + c += s[(a & (sizeof(s)-1))]; + + unsigned char s2[] = "Tim is sorry at the playa\n"; + c += s2[a & (sizeof(s) - 1)]; + + c += a*b; + c += a-b; + c += a << (b & 0x8); + + c += sum(a, b); +END_TEST32() diff --git a/test/kvx/instr/i64.c b/test/kvx/instr/i64.c new file mode 100644 index 00000000..e869d93c --- /dev/null +++ b/test/kvx/instr/i64.c @@ -0,0 +1,169 @@ +#include "framework.h" + +long long sum(long long a, long long b){ + return a+b; +} + +long long diff(long long a, long long b){ + return a-b; +} + +long long mul(long long a, long long b){ + return a*b; +} + +long long make(long long a){ + return a; +} + +long long random_op(long long a, long long b){ + long long d = 3; + long long (*op)(long long, long long); + + if (a % d == 0) + op = sum; + else if (a % d == 1) + op = diff; + else + op = mul; + + return op(a, b); +} + +long fact(long a){ + long r = 1; + long i; + for (i = 1; i < a; i++) + r *= i; + return r; +} + +double long2double(long v){ + return v; +} + +BEGIN_TEST(long long) + c = a&b; + c += a*b; + c += -a; + c += a | b; + c += a-b; + c += a >> (b & 0x8LL); + c += a >> (b & 0x8ULL); + c += a % b; + c += (a << 4); // addx16d + c += (a << 3); // addx8d + c += (a << 2); // addx4d + c += (a << 1); // addx2d + + c += ~a & b; // andnd + + long long d = 3; + long long (*op)(long long, long long); + + if (a % d == 0) + op = sum; + else if (a % d == 1) + op = diff; + else + op = mul; + + c += op(make(a), make(b)); + c += random_op(a, b); + c += a/b; + c += a^b; + c += (unsigned int) a; + + /* Testing if, cb */ + if (0 != (a & 0x1LL)) + c += fact(1); + else + c += fact(2); + + if (0 > (a & 0x1LL)) + c += fact(4); + else + c += fact(8); + + if (0 >= (a & 0x1LL) - 1) + c += fact(16); + else + c += fact(32); + + if ((unsigned long long)(a & 0x1LL) >= 1) + c += fact(18); + else + c += fact(31); + + + if (a-41414141 > 0) + c += fact(13); + else + c += fact(31); + + if (a & 0x1LL > 0) + c += fact(64); + else + c += fact(128); + + if ((a & 0x1LL) - 1 >= 0) + c += fact(256); + else + c += fact(512); + + if (0 == (a & 0x1LL)) + c += fact(1024); + else + c += fact(2048); + + /* Testing if, cmoved */ + if (0 != (a & 0x1LL)) + c += 1; + else + c += 2; + + if (0 > (a & 0x1LL)) + c += 4; + else + c += 8; + + if (0 >= (a & 0x1LL) - 1) + c += 16; + else + c += 32; + + if (a-41414141 > 0) + c += 13; + else + c += 31; + + if (a & 0x1LL > 0) + c += 64; + else + c += 128; + + if ((a & 0x1LL) - 1 >= 0) + c += 256; + else + c += 512; + + if (0 == (a & 0x1LL)) + c += 1024; + else + c += 2048; + + c += ((a & 0x1LL) == (b & 0x1LL)); + c += (a >= b); + c += (a > b); + c += (a <= b); + c += (a < b); + c += (long) long2double(a) + (long) long2double(b) + (long) long2double(42.3); + + int j; + + for (j = 0 ; j < (b & 0x8LL) ; j++) + c += a; + + c += ((a & 0x1LL) == (b & 0x1LL)); + +END_TEST64() diff --git a/test/kvx/instr/individual/andw.c b/test/kvx/instr/individual/andw.c new file mode 100644 index 00000000..799dc7fb --- /dev/null +++ b/test/kvx/instr/individual/andw.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(int) + c = a&b; +END_TEST32() diff --git a/test/kvx/instr/individual/branch.c b/test/kvx/instr/individual/branch.c new file mode 100644 index 00000000..c9937e31 --- /dev/null +++ b/test/kvx/instr/individual/branch.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) == 1) + c = 0; + else + c = 1; +} +END_TEST32() diff --git a/test/kvx/instr/individual/branchz.c b/test/kvx/instr/individual/branchz.c new file mode 100644 index 00000000..d3e021b5 --- /dev/null +++ b/test/kvx/instr/individual/branchz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (a & 0x1 == 0) + c = 0; + else + c = 1; +} +END_TEST32() diff --git a/test/kvx/instr/individual/branchzu.c b/test/kvx/instr/individual/branchzu.c new file mode 100644 index 00000000..d0169174 --- /dev/null +++ b/test/kvx/instr/individual/branchzu.c @@ -0,0 +1,11 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + b = !(a & 0x01); + if (!b) + c = 0; + else + c = 1; +} +END_TEST32() diff --git a/test/kvx/instr/individual/call.c b/test/kvx/instr/individual/call.c new file mode 100644 index 00000000..ba2ec323 --- /dev/null +++ b/test/kvx/instr/individual/call.c @@ -0,0 +1,16 @@ +#include "framework.h" + +int sum(int a, int b){ + return a+b; +} + +int make(int a){ + return a; +} + +BEGIN_TEST(int) +{ + c = sum(make(a), make(b)); +} +END_TEST32() +/* RETURN VALUE: 60 */ diff --git a/test/kvx/instr/individual/cast_S32_S64.c b/test/kvx/instr/individual/cast_S32_S64.c new file mode 100644 index 00000000..09c97e00 --- /dev/null +++ b/test/kvx/instr/individual/cast_S32_S64.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (long long) a; +} +END_TEST32() diff --git a/test/kvx/instr/individual/cast_S64_U32.c b/test/kvx/instr/individual/cast_S64_U32.c new file mode 100644 index 00000000..2d9dc723 --- /dev/null +++ b/test/kvx/instr/individual/cast_S64_U32.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (unsigned int) a; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.deqz.c b/test/kvx/instr/individual/cb.deqz.c new file mode 100644 index 00000000..6da2ab07 --- /dev/null +++ b/test/kvx/instr/individual/cb.deqz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 != (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.dgez.c b/test/kvx/instr/individual/cb.dgez.c new file mode 100644 index 00000000..7bef25ad --- /dev/null +++ b/test/kvx/instr/individual/cb.dgez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 > (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.dgtz.c b/test/kvx/instr/individual/cb.dgtz.c new file mode 100644 index 00000000..1a43fb1f --- /dev/null +++ b/test/kvx/instr/individual/cb.dgtz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 >= (a & 0x1LL) - 1) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.dlez.c b/test/kvx/instr/individual/cb.dlez.c new file mode 100644 index 00000000..2fb97939 --- /dev/null +++ b/test/kvx/instr/individual/cb.dlez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (a & 0x1LL > 0) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.dltz.c b/test/kvx/instr/individual/cb.dltz.c new file mode 100644 index 00000000..a431d5d0 --- /dev/null +++ b/test/kvx/instr/individual/cb.dltz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if ((a & 0x1LL) - 1 >= 0) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.dnez.c b/test/kvx/instr/individual/cb.dnez.c new file mode 100644 index 00000000..44516cbe --- /dev/null +++ b/test/kvx/instr/individual/cb.dnez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + if (0 == (a & 0x1LL)) + c = 1; + else + c = 0; +} +END_TEST64() diff --git a/test/kvx/instr/individual/cb.wgez.c b/test/kvx/instr/individual/cb.wgez.c new file mode 100644 index 00000000..5779ad92 --- /dev/null +++ b/test/kvx/instr/individual/cb.wgez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (0 > (a & 0x1) - 1) + c = 1; + else + c = 0; +} +END_TEST32() diff --git a/test/kvx/instr/individual/cb.wgtz.c b/test/kvx/instr/individual/cb.wgtz.c new file mode 100644 index 00000000..abb695bd --- /dev/null +++ b/test/kvx/instr/individual/cb.wgtz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if (0 >= (a & 0x1)) + c = 1; + else + c = 0; +} +END_TEST32() diff --git a/test/kvx/instr/individual/cb.wlez.c b/test/kvx/instr/individual/cb.wlez.c new file mode 100644 index 00000000..3a2e08c1 --- /dev/null +++ b/test/kvx/instr/individual/cb.wlez.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) > 0) + c = 1; + else + c = 0; +} +END_TEST32() diff --git a/test/kvx/instr/individual/cb.wltz.c b/test/kvx/instr/individual/cb.wltz.c new file mode 100644 index 00000000..5d52c72a --- /dev/null +++ b/test/kvx/instr/individual/cb.wltz.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + if ((a & 0x1) - 1 >= 0) + c = 1; + else + c = 0; +} +END_TEST32() diff --git a/test/kvx/instr/individual/compd.eq.c b/test/kvx/instr/individual/compd.eq.c new file mode 100644 index 00000000..4fe8de2a --- /dev/null +++ b/test/kvx/instr/individual/compd.eq.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = ((a & 0x1LL) == (b & 0x1LL)); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.geu.c b/test/kvx/instr/individual/compd.geu.c new file mode 100644 index 00000000..fccf0804 --- /dev/null +++ b/test/kvx/instr/individual/compd.geu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a >= b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.gt.c b/test/kvx/instr/individual/compd.gt.c new file mode 100644 index 00000000..b9901436 --- /dev/null +++ b/test/kvx/instr/individual/compd.gt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a > b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.le.c b/test/kvx/instr/individual/compd.le.c new file mode 100644 index 00000000..6fa0f103 --- /dev/null +++ b/test/kvx/instr/individual/compd.le.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a <= b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.leu.c b/test/kvx/instr/individual/compd.leu.c new file mode 100644 index 00000000..1ad18281 --- /dev/null +++ b/test/kvx/instr/individual/compd.leu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a <= b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.lt.c b/test/kvx/instr/individual/compd.lt.c new file mode 100644 index 00000000..c42cda56 --- /dev/null +++ b/test/kvx/instr/individual/compd.lt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = (a < b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.ltu.c b/test/kvx/instr/individual/compd.ltu.c new file mode 100644 index 00000000..b03d4d53 --- /dev/null +++ b/test/kvx/instr/individual/compd.ltu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a < b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compd.ne.c b/test/kvx/instr/individual/compd.ne.c new file mode 100644 index 00000000..fd9d0b28 --- /dev/null +++ b/test/kvx/instr/individual/compd.ne.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = ((a & 0x1ULL) != (b & 0x1ULL)); +} +END_TEST64() diff --git a/test/kvx/instr/individual/compw.eq.c b/test/kvx/instr/individual/compw.eq.c new file mode 100644 index 00000000..cd93f365 --- /dev/null +++ b/test/kvx/instr/individual/compw.eq.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = ((a & 0x1) == (b & 0x1)); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.geu.c b/test/kvx/instr/individual/compw.geu.c new file mode 100644 index 00000000..b8fb1adf --- /dev/null +++ b/test/kvx/instr/individual/compw.geu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a >= b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.gt.c b/test/kvx/instr/individual/compw.gt.c new file mode 100644 index 00000000..5f6bc907 --- /dev/null +++ b/test/kvx/instr/individual/compw.gt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a > b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.gtu.c b/test/kvx/instr/individual/compw.gtu.c new file mode 100644 index 00000000..947f6a14 --- /dev/null +++ b/test/kvx/instr/individual/compw.gtu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a > b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.le.c b/test/kvx/instr/individual/compw.le.c new file mode 100644 index 00000000..35ec6b7d --- /dev/null +++ b/test/kvx/instr/individual/compw.le.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a <= b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.leu.c b/test/kvx/instr/individual/compw.leu.c new file mode 100644 index 00000000..74ebfb42 --- /dev/null +++ b/test/kvx/instr/individual/compw.leu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a <= b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.lt.c b/test/kvx/instr/individual/compw.lt.c new file mode 100644 index 00000000..cb1f30bd --- /dev/null +++ b/test/kvx/instr/individual/compw.lt.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a < b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.ltu.c b/test/kvx/instr/individual/compw.ltu.c new file mode 100644 index 00000000..6a0c5af1 --- /dev/null +++ b/test/kvx/instr/individual/compw.ltu.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (a < b); +} +END_TEST32() diff --git a/test/kvx/instr/individual/compw.ne.c b/test/kvx/instr/individual/compw.ne.c new file mode 100644 index 00000000..7035e2c7 --- /dev/null +++ b/test/kvx/instr/individual/compw.ne.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = ((a & 0x1U) != (b & 0x1U)); +} +END_TEST32() diff --git a/test/kvx/instr/individual/div2.c b/test/kvx/instr/individual/div2.c new file mode 100644 index 00000000..b5dfe63a --- /dev/null +++ b/test/kvx/instr/individual/div2.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = (a + b) / 2; +} +END_TEST32() diff --git a/test/kvx/instr/individual/doubleconv.c b/test/kvx/instr/individual/doubleconv.c new file mode 100644 index 00000000..55b1ddab --- /dev/null +++ b/test/kvx/instr/individual/doubleconv.c @@ -0,0 +1,9 @@ +#include "framework.h" + +double long2double(long v){ + return v; +} + +BEGIN_TEST(long) + c = (long) long2double(a) + (long) long2double(b) + (long) long2double(42.3); +END_TEST64() diff --git a/test/kvx/instr/individual/floatconv.c b/test/kvx/instr/individual/floatconv.c new file mode 100644 index 00000000..32b798e1 --- /dev/null +++ b/test/kvx/instr/individual/floatconv.c @@ -0,0 +1,9 @@ +#include "framework.h" + +float int2float(int v){ + return v; +} + +BEGIN_TEST(int) + c = (int) int2float(a) + (int) int2float(b) + (int) int2float(42.3); +END_TEST32() diff --git a/test/kvx/instr/individual/fmuld.c b/test/kvx/instr/individual/fmuld.c new file mode 100644 index 00000000..03c990fa --- /dev/null +++ b/test/kvx/instr/individual/fmuld.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(double) +{ + c = ((double)a * (double)b); +} +END_TESTF64() diff --git a/test/kvx/instr/individual/fmulw.c b/test/kvx/instr/individual/fmulw.c new file mode 100644 index 00000000..f85eba64 --- /dev/null +++ b/test/kvx/instr/individual/fmulw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(float) +{ + c = ((float)a * (float)b); +} +END_TESTF32() diff --git a/test/kvx/instr/individual/fnegd.c b/test/kvx/instr/individual/fnegd.c new file mode 100644 index 00000000..974eb7e8 --- /dev/null +++ b/test/kvx/instr/individual/fnegd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(double) +{ + c = (-(double)a); +} +END_TESTF64() diff --git a/test/kvx/instr/individual/fnegw.c b/test/kvx/instr/individual/fnegw.c new file mode 100644 index 00000000..fbeaab8e --- /dev/null +++ b/test/kvx/instr/individual/fnegw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(float) +{ + c = (-(float)a); +} +END_TESTF64() diff --git a/test/kvx/instr/individual/for.c b/test/kvx/instr/individual/for.c new file mode 100644 index 00000000..373ab6bd --- /dev/null +++ b/test/kvx/instr/individual/for.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + int j; + for (j = 0 ; j < 10 ; j++) + c += a; +} +END_TEST32() diff --git a/test/kvx/instr/individual/forvar.c b/test/kvx/instr/individual/forvar.c new file mode 100644 index 00000000..9e43c198 --- /dev/null +++ b/test/kvx/instr/individual/forvar.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + int k; + for (k = 0 ; k < (b & 0x8) ; k++) + c += a; +} +END_TEST32() diff --git a/test/kvx/instr/individual/forvarl.c b/test/kvx/instr/individual/forvarl.c new file mode 100644 index 00000000..c1fe90fd --- /dev/null +++ b/test/kvx/instr/individual/forvarl.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(long long int) +{ + int j; + + for (j = 0 ; j < (b & 0x8LL) ; j++) + c += a; +} +END_TEST64() diff --git a/test/kvx/instr/individual/fsbfd.c b/test/kvx/instr/individual/fsbfd.c new file mode 100644 index 00000000..f80c1efe --- /dev/null +++ b/test/kvx/instr/individual/fsbfd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(double) +{ + c = ((double)a - (double)b); +} +END_TESTF64() diff --git a/test/kvx/instr/individual/fsbfw.c b/test/kvx/instr/individual/fsbfw.c new file mode 100644 index 00000000..067c40b5 --- /dev/null +++ b/test/kvx/instr/individual/fsbfw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(float) +{ + c = ((float)a - (float)b); +} +END_TESTF64() diff --git a/test/kvx/instr/individual/indirect_call.c b/test/kvx/instr/individual/indirect_call.c new file mode 100644 index 00000000..f376c00a --- /dev/null +++ b/test/kvx/instr/individual/indirect_call.c @@ -0,0 +1,33 @@ +#include "framework.h" + +long long sum(long long a, long long b){ + return a+b; +} + +long long diff(long long a, long long b){ + return a-b; +} + +long long mul(long long a, long long b){ + return a*b; +} + +long long make(long long a){ + return a; +} + +BEGIN_TEST(long long) +{ + long long d = 3; + long long (*op)(long long, long long); + + if (a % d == 0) + op = sum; + else if (a % d == 1) + op = diff; + else + op = mul; + + c += op(make(a), make(b)); +} +END_TEST64() diff --git a/test/kvx/instr/individual/indirect_tailcall.c b/test/kvx/instr/individual/indirect_tailcall.c new file mode 100644 index 00000000..e6c16ea1 --- /dev/null +++ b/test/kvx/instr/individual/indirect_tailcall.c @@ -0,0 +1,33 @@ +#include "framework.h" + +long long sum(long long a, long long b){ + return a+b; +} + +long long diff(long long a, long long b){ + return a-b; +} + +long long mul(long long a, long long b){ + return a*b; +} + +long long random_op(long long a, long long b){ + long long d = 3; + long long (*op)(long long, long long); + + if (a % d == 0) + op = sum; + else if (a % d == 1) + op = diff; + else + op = mul; + + return op(a, b); +} + +BEGIN_TEST(long long) +{ + c += random_op(a, b); +} +END_TEST64() diff --git a/test/kvx/instr/individual/lbs.c b/test/kvx/instr/individual/lbs.c new file mode 100644 index 00000000..22a50632 --- /dev/null +++ b/test/kvx/instr/individual/lbs.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + char s[] = "Tome and Cherry at the playa\n"; + + c = s[(a & (sizeof(s)-1))]; +} +END_TEST32() diff --git a/test/kvx/instr/individual/lbz.c b/test/kvx/instr/individual/lbz.c new file mode 100644 index 00000000..04ba098d --- /dev/null +++ b/test/kvx/instr/individual/lbz.c @@ -0,0 +1,9 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + unsigned char s[] = "Tim is sorry at the playa\n"; + + c = s[a & (sizeof(s) - 1)]; +} +END_TEST32() diff --git a/test/kvx/instr/individual/muld.c b/test/kvx/instr/individual/muld.c new file mode 100644 index 00000000..f7e23850 --- /dev/null +++ b/test/kvx/instr/individual/muld.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a*b; +} +END_TEST64() diff --git a/test/kvx/instr/individual/mulw.c b/test/kvx/instr/individual/mulw.c new file mode 100644 index 00000000..a91d966e --- /dev/null +++ b/test/kvx/instr/individual/mulw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a * b; +} +END_TEST32() diff --git a/test/kvx/instr/individual/negd.c b/test/kvx/instr/individual/negd.c new file mode 100644 index 00000000..837b9828 --- /dev/null +++ b/test/kvx/instr/individual/negd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = -a; +} +END_TEST64() diff --git a/test/kvx/instr/individual/ord.c b/test/kvx/instr/individual/ord.c new file mode 100644 index 00000000..cae1ae8b --- /dev/null +++ b/test/kvx/instr/individual/ord.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a | b; +} +END_TEST64() diff --git a/test/kvx/instr/individual/sbfd.c b/test/kvx/instr/individual/sbfd.c new file mode 100644 index 00000000..77c28c77 --- /dev/null +++ b/test/kvx/instr/individual/sbfd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a-b; +} +END_TEST64() diff --git a/test/kvx/instr/individual/sbfw.c b/test/kvx/instr/individual/sbfw.c new file mode 100644 index 00000000..e38a1fff --- /dev/null +++ b/test/kvx/instr/individual/sbfw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a-b; +} +END_TEST32() diff --git a/test/kvx/instr/individual/simple.c b/test/kvx/instr/individual/simple.c new file mode 100644 index 00000000..944f09c9 --- /dev/null +++ b/test/kvx/instr/individual/simple.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a+b; +} +END_TEST32() diff --git a/test/kvx/instr/individual/sllw.c b/test/kvx/instr/individual/sllw.c new file mode 100644 index 00000000..6dd41a6c --- /dev/null +++ b/test/kvx/instr/individual/sllw.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(int) +{ + c = a << (b & 0x8); +} +END_TEST32() diff --git a/test/kvx/instr/individual/srad.c b/test/kvx/instr/individual/srad.c new file mode 100644 index 00000000..00be9d0c --- /dev/null +++ b/test/kvx/instr/individual/srad.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a >> (b & 0x8LL); +} +END_TEST64() diff --git a/test/kvx/instr/individual/srld.c b/test/kvx/instr/individual/srld.c new file mode 100644 index 00000000..14970efd --- /dev/null +++ b/test/kvx/instr/individual/srld.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a >> (b & 0x8ULL); +} +END_TEST64() diff --git a/test/kvx/instr/individual/tailcall.c b/test/kvx/instr/individual/tailcall.c new file mode 100644 index 00000000..6c659a01 --- /dev/null +++ b/test/kvx/instr/individual/tailcall.c @@ -0,0 +1,16 @@ +#include "framework.h" + +int make(int a){ + return a; +} + +int sum(int a, int b){ + return make(a+b); +} + +BEGIN_TEST(int) +{ + c = sum(a, b); +} +END_TEST32() +/* RETURN VALUE: 60 */ diff --git a/test/kvx/instr/individual/udivd.c b/test/kvx/instr/individual/udivd.c new file mode 100644 index 00000000..cfb31881 --- /dev/null +++ b/test/kvx/instr/individual/udivd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a/b; +} +END_TEST64() diff --git a/test/kvx/instr/individual/umodd.c b/test/kvx/instr/individual/umodd.c new file mode 100644 index 00000000..a7f25f1c --- /dev/null +++ b/test/kvx/instr/individual/umodd.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = a%b; +} +END_TEST64() diff --git a/test/kvx/instr/individual/xord.c b/test/kvx/instr/individual/xord.c new file mode 100644 index 00000000..b6a90cb0 --- /dev/null +++ b/test/kvx/instr/individual/xord.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(long long) +{ + c = a^b; +} +END_TEST64() diff --git a/test/kvx/instr/modi32.c b/test/kvx/instr/modi32.c new file mode 100644 index 00000000..958ae920 --- /dev/null +++ b/test/kvx/instr/modi32.c @@ -0,0 +1,5 @@ +#include "framework.h" + +BEGIN_TEST(int) + c = a%b; +END_TEST32() diff --git a/test/kvx/instr/modui32.c b/test/kvx/instr/modui32.c new file mode 100644 index 00000000..a39034a8 --- /dev/null +++ b/test/kvx/instr/modui32.c @@ -0,0 +1,7 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = a%b; +} +END_TEST32() diff --git a/test/kvx/instr/ui32.c b/test/kvx/instr/ui32.c new file mode 100644 index 00000000..f56a9b95 --- /dev/null +++ b/test/kvx/instr/ui32.c @@ -0,0 +1,12 @@ +#include "framework.h" + +BEGIN_TEST(unsigned int) +{ + c = (long long) a; + c += (a >= b); + c += (a > b); + c += (a <= b); + c += (a < b); + c += ((a & 0x1U) != (b & 0x1U)); +} +END_TEST32() diff --git a/test/kvx/instr/ui64.c b/test/kvx/instr/ui64.c new file mode 100644 index 00000000..908dec3c --- /dev/null +++ b/test/kvx/instr/ui64.c @@ -0,0 +1,10 @@ +#include "framework.h" + +BEGIN_TEST(unsigned long long) +{ + c = (a > b); + c += (a <= b); + c += (a < b); + c += ((a & 0x1ULL) != (b & 0x1ULL)); +} +END_TEST64() diff --git a/test/kvx/interop/.gitignore b/test/kvx/interop/.gitignore new file mode 100644 index 00000000..ea1472ec --- /dev/null +++ b/test/kvx/interop/.gitignore @@ -0,0 +1 @@ +output/ diff --git a/test/kvx/interop/Makefile b/test/kvx/interop/Makefile new file mode 100644 index 00000000..a0d4d7da --- /dev/null +++ b/test/kvx/interop/Makefile @@ -0,0 +1,365 @@ +SHELL := /bin/bash + +KVXC ?= k1-cos-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 -Wno-varargs +SIMU ?= k1-mppa +TIMEOUT ?= --signal=SIGTERM 120s +HARDRUN ?= k1-jtag-runner + +DIR=./ +SRCDIR=$(DIR) +OUTDIR=$(DIR)/out +BINDIR=$(DIR)/bin +ASMDIR=$(DIR)/asm +OBJDIR=$(DIR)/obj +COMMON=common +VAARG_COMMON=vaarg_common + +## +# Intended flow : .c -> .gcc.s -> .gcc.o -> .gcc.bin -> .gcc.out +# -> .ccomp.s -> .ccomp.o -> .ccomp.bin -> .ccomp.out +# -> .x86-gcc.s -> .x86-gcc.o -> .x86-gcc.bin -> .x86-gcc.out +# +# The .o -> .bin part uses $(COMMON).gcc.o or $(COMMON).x86-gcc.o depending on the architecture +# There is also a $(VAARG_COMMON) that is the same than $(COMMON) but with va_arg +## + +KVXCPATH=$(shell which $(KVXC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +TESTNAMES ?= $(filter-out $(VAARG_COMMON),$(filter-out $(COMMON),$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))))) + +X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) +GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES))) +GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.simu.out,$(TESTNAMES))) +CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES))) + +GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES))) +GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.hard.out,$(TESTNAMES))) +CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES))) + +VAARG_X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.vaarg.out,$(TESTNAMES))) +VAARG_GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.simu.out,$(TESTNAMES))) +VAARG_GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.simu.out,$(TESTNAMES))) +VAARG_CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.simu.out,$(TESTNAMES))) + +VAARG_GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.hard.out,$(TESTNAMES))) +VAARG_GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.hard.out,$(TESTNAMES))) +VAARG_CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.hard.out,$(TESTNAMES))) + +BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.rev.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.vaarg.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.vaarg.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .ccomp.vaarg.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.rev.vaarg.bin,$(TESTNAMES))) + +## +# Targets +## + +all: $(BIN) + +GREEN=\033[0;32m +RED=\033[0;31m +NC=\033[0m + +.PHONY: +test: simutest + +.PHONY: +simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_SIMUOUT) + @echo "Comparing x86 gcc output to k1 gcc.." + @for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.simu.out;\ + vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\ + vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\ + if ! diff $$x86out $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_x86out $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_x86out and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_x86out and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +check: simucheck + +.PHONY: +simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) $(GCC_REV_SIMUOUT) $(VAARG_GCC_SIMUOUT) $(VAARG_CCOMP_SIMUOUT) $(VAARG_GCC_REV_SIMUOUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.simu.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\ + gccrevout=$(OUTDIR)/$$test.gcc.rev.simu.out;\ + vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\ + vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.simu.out;\ + vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.simu.out;\ + if ! diff $$ccompout $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$gccrevout $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$gccrevout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$gccrevout and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_ccompout $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_ccompout and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_ccompout and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_gccrevout $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_gccrevout and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_gccrevout and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_HARDOUT) + @echo "Comparing x86 gcc output to k1 gcc.." + @for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.hard.out;\ + vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\ + vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\ + if ! diff $$x86out $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_x86out $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_x86out and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_x86out and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + done + +.PHONY: +hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT) $(GCC_REV_HARDOUT) $(VAARG_GCC_HARDOUT) $(VAARG_CCOMP_HARDOUT) $(VAARG_GCC_REV_HARDOUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.hard.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\ + gccrevout=$(OUTDIR)/$$test.gcc.rev.hard.out;\ + vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\ + vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.hard.out;\ + vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.hard.out;\ + if ! diff $$ccompout $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$gccrevout $$gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$gccrevout and $$gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$gccrevout and $$gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_ccompout $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_ccompout and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_ccompout and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + if ! diff $$vaarg_gccrevout $$vaarg_gccout > /dev/null; then\ + >&2 printf "$(RED)ERROR: $$vaarg_gccrevout and $$vaarg_gccout differ$(NC)\n";\ + else\ + printf "$(GREEN)GOOD: $$vaarg_gccrevout and $$vaarg_gccout concur$(NC)\n";\ + fi;\ + done + +## +# Rules +## + +.SECONDARY: + +## +# Generating output +## + +## Version sans les timeout +#$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin +# @mkdir -p $(@D) +# ./$< > $@; echo $$? >> $@ +# +#$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) +# @mkdir -p $(@D) +# $(SIMU) -- $< > $@ ; echo $$? >> $@ +# +#$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) +# @mkdir -p $(@D) +# $(SIMU) -- $< > $@ ; echo $$? >> $@ + +## No vaarg + +$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.rev.simu.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.rev.hard.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +## With vaarg + +$(OUTDIR)/%.x86-gcc.vaarg.out: $(BINDIR)/%.x86-gcc.vaarg.bin + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.vaarg.simu.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.rev.vaarg.simu.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.vaarg.simu.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.vaarg.hard.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.rev.vaarg.hard.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.vaarg.hard.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +## +# Object to binary +## + +## common + +$(BINDIR)/$(COMMON).x86-gcc.bin: $(OBJDIR)/$(COMMON).x86-gcc.o $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $< -o $@ + +$(BINDIR)/$(COMMON).gcc.bin: $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $< -o $@ + +$(BINDIR)/$(COMMON).ccomp.bin: $(OBJDIR)/$(COMMON).ccomp.o $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $< -o $@ + +## vaarg_common + +$(BINDIR)/$(VAARG_COMMON).x86-gcc.bin: $(OBJDIR)/$(VAARG_COMMON).x86-gcc.o $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $< -o $@ + +$(BINDIR)/$(VAARG_COMMON).gcc.bin: $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $< -o $@ + +$(BINDIR)/$(VAARG_COMMON).ccomp.bin: $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $< -o $@ + +## no vaarg + +$(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(COMMON).x86-gcc.o $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.gcc.rev.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).ccomp.o $(KVXCPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.ccomp.bin: $(OBJDIR)/%.ccomp.o $(OBJDIR)/$(COMMON).gcc.o $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +## with vaarg + +$(BINDIR)/%.x86-gcc.vaarg.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(VAARG_COMMON).x86-gcc.o $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.gcc.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.gcc.rev.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(KVXCPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +$(BINDIR)/%.ccomp.vaarg.bin: $(OBJDIR)/%.ccomp.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ + +## +# Assembly to object +## + +$(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) + @mkdir -p $(@D) + $(CC) -c $(CFLAGS) $< -o $@ + +$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) -c $(CFLAGS) $< -o $@ + +$(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) -c $(CFLAGS) $< -o $@ + + +## +# Source to assembly +## + +$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) -S $< -o $@ diff --git a/test/kvx/interop/common.c b/test/kvx/interop/common.c new file mode 100644 index 00000000..05b49187 --- /dev/null +++ b/test/kvx/interop/common.c @@ -0,0 +1,257 @@ +#define STACK int a[100];\ + a[42] = 42; + +#define ONEARG_OP(arg) (3*magic(arg)+2) + +#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4) + +#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\ + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\ + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\ + (a0 * a1 * a2 * magic(a3) * a4 * a5 * a6 * a7 * a8 * a9 *\ + a10 * a11 * a12 * a13 * a14 * a15 * a16 * a17 * a18 * a19 *\ + a20 * a21 * a22 * a23 * a24 * a25 * a26 * a27 * a28 * a29) + +int magic(long a){ + return a*42 + 26; +} + +void void_void(){ + STACK; +} + +long long ll_void(){ + STACK; + return 0xdeadbeefdeadbeefULL; +} + +int i_oneiarg(int arg){ + STACK; + return ONEARG_OP(arg); +} + +int i_multiiargs(int arg1, char arg2, char arg3, int arg4){ + STACK; + return MULTIARG_OP(arg1, arg2, arg3, arg4); +} + +int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, + char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, + char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29) +{ + STACK; + return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); +} + +int ll_onellarg(long long arg){ + STACK; + return ONEARG_OP(arg); +} + +long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4){ + STACK; + return MULTIARG_OP(arg1, arg2, arg3, arg4); +} + +long long ll_manyllargs(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, + char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, + char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) +{ + STACK; + return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); +} + +double stackhell(char a0, int a1, float a2, long long a3, double a4, char a5, long long a6, long long a7, float a8, long long a9, + double a10, long long a11, char a12, int a13, float a14, double a15, long long a16, long long a17, float a18, long long a19, + char a20, int a21, char a22, long long a23, float a24, char a25, long long a26, int a27, double a28, long long a29) +{ + long long b0 = a0; + long long b1 = a1 * b0; + long long b2 = a2 * b1; + float b3 = a3 * b2; + int b4 = a4 * b3; + double b5 = a5 * b4; + int b6 = a6 * b5; + float b7 = a7 * b6; + char b8 = a8 * b7; + double b9 = a9 * b8; + char b10 = a10 * b9; + float b11 = a11 * b10; + char b12 = a12 * b11; + int b13 = a13 * b12; + long long b14 = a14 * b13; + long long b15 = a15 * b14; + long long b16 = a16 * b15; + long long b17 = a17 * b16; + long long b18 = a18 * b17; + long long b19 = a19 * b18; + long long b20 = a20 * b19; + long long b21 = a21 * b20; + long long b22 = a22 * b21; + long long b23 = a23 * b22; + long long b24 = a24 * b23; + long long b25 = a25 * b24; + long long b26 = a26 * b25; + long long b27 = a27 * b26; + int b28 = a28 * b27; + double b29 = a29 * b28; + float b30 = b0 * b29; + double b31 = b1 * b30; + int b32 = b2 * b31; + char b33 = b3 * b32; + float b34 = b4 * b33; + char b35 = b5 * b34; + double b36 = b6 * b35; + float b37 = b7 * b36; + int b38 = b8 * b37; + double b39 = b9 * b38; + float b40 = b0 * b39; + int b41 = b1 * b40; + double b42 = b2 * b41; + float b43 = b3 * b42; + int b44 = b4 * b43; + double b45 = b5 * b44; + int b46 = b6 * b45; + double b47 = b7 * b46; + int b48 = b8 * b47; + long long b49 = b9 * b48; + long long b50 = b0 * b49; + long long b51 = b1 * b50; + long long b52 = b2 * b51; + long long b53 = b3 * b52; + long long b54 = b4 * b53; + long long b55 = b5 * b54; + long long b56 = b6 * b55; + long long b57 = b7 * b56; + int b58 = b8 * b57; + float b59 = b9 * b58; + int b60 = b0 * b59; + float b61 = b1 * b60; + float b62 = b2 * b61; + int b63 = b3 * b62; + double b64 = b4 * b63; + int b65 = b5 * b64; + int b66 = b6 * b65; + double b67 = b7 * b66; + double b68 = b8 * b67; + int b69 = b9 * b68; + char b70 = b0 * b69; + char b71 = b1 * b70; + double b72 = b2 * b71; + double b73 = b3 * b72; + char b74 = b4 * b73; + float b75 = b5 * b74; + float b76 = b6 * b75; + double b77 = b7 * b76; + char b78 = b8 * b77; + float b79 = b9 * b78; + float b80 = b0 * b79; + char b81 = b1 * b80; + char b82 = b2 * b81; + float b83 = b3 * b82; + char b84 = b4 * b83; + int b85 = b5 * b84; + int b86 = b6 * b85; + double b87 = b7 * b86; + float b88 = b8 * b87; + double b89 = b9 * b88; + int b90 = b0 * b89; + float b91 = b1 * b90; + double b92 = b2 * b91; + int b93 = b3 * b92; + int b94 = b4 * b93; + long long b95 = b5 * b94; + long long b96 = b6 * b95; + long long b97 = b7 * b96; + long long b98 = b8 * b97; + long long b99 = b9 * b98; + long long b100 = b0 * b99; + long long b101 = b1 * b100; + long long b102 = b2 * b101; + long long b103 = b3 * b102; + long long b104 = b4 * b103; + long long b105 = b5 * b104; + long long b106 = b6 * b105; + long long b107 = b7 * b106; + long long b108 = b8 * b107; + long long b109 = b9 * b108; + long long b110 = b0 * b109; + long long b111 = b1 * b110; + long long b112 = b2 * b111; + long long b113 = b3 * b112; + long long b114 = b4 * b113; + int b115 = b5 * b114; + int b116 = b6 * b115; + int b117 = b7 * b116; + float b118 = b8 * b117; + float b119 = b9 * b118; + int b120 = b0 * b119; + double b121 = b1 * b120; + float b122 = b2 * b121; + int b123 = b3 * b122; + double b124 = b4 * b123; + int b125 = b5 * b124; + char b126 = b6 * b125; + double b127 = b7 * b126; + char b128 = b8 * b127; + float b129 = b9 * b128; + char b130 = b0 * b129; + double b131 = b1 * b130; + char b132 = b2 * b131; + float b133 = b3 * b132; + char b134 = b4 * b133; + double b135 = b5 * b134; + char b136 = b6 * b135; + float b137 = b7 * b136; + char b138 = b8 * b137; + double b139 = b9 * b138; + char b140 = b0 * b139; + float b141 = b1 * b140; + char b142 = b2 * b141; + double b143 = b3 * b142; + char b144 = b4 * b143; + float b145 = b5 * b144; + char b146 = b6 * b145; + double b147 = b7 * b146; + int b148 = b8 * b147; + float b149 = b9 * b148; + int b150 = b0 * b149; + double b151 = b1 * b150; + int b152 = b2 * b151; + float b153 = b3 * b152; + int b154 = b4 * b153; + double b155 = b5 * b154; + int b156 = b6 * b155; + float b157 = b7 * b156; + int b158 = b8 * b157; + double b159 = b9 * b158; + int b160 = b0 * b159; + float b161 = b1 * b160; + int b162 = b2 * b161; + return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) + * b0 * b1 * b2 * b3 * b4 * b5 * b6 * b7 * b8 * b9 + * b10 * b11 * b12 * b13 * b14 * b15 * b16 * b17 * b18 * b19 + * b20 * b21 * b22 * b23 * b24 * b25 * b26 * b27 * b28 * b29 + * b30 * b31 * b32 * b33 * b34 * b35 * b36 * b37 * b38 * b39 + * b40 * b41 * b42 * b43 * b44 * b45 * b46 * b47 * b48 * b49 + * b50 * b51 * b52 * b53 * b54 * b55 * b56 * b57 * b58 * b59 + * b60 * b61 * b62 * b63 * b64 * b65 * b66 * b67 * b68 * b69 + * b70 * b71 * b72 * b73 * b74 * b75 * b76 * b77 * b78 * b79 + * b80 * b81 * b82 * b83 * b84 * b85 * b86 * b87 * b88 * b89 + * b90 * b91 * b92 * b93 * b94 * b95 * b96 * b97 * b98 * b99 + * b100 * b101 * b102 * b103 * b104 * b105 * b106 * b107 * b108 * b109 + * b110 * b111 * b112 * b113 * b114 * b115 * b116 * b117 * b118 * b119 + * b120 * b121 * b122 * b123 * b124 * b125 * b126 * b127 * b128 * b129 + * b130 * b131 * b132 * b133 * b134 * b135 * b136 * b137 * b138 * b139 + * b140 * b141 * b142 * b143 * b144 * b145 * b146 * b147 * b148 * b149 + * b150 * b151 * b152 * b153 * b154 * b155 * b156 * b157 * b158 * b159 + * b160 * b161 * b162 + ; +} + diff --git a/test/kvx/interop/common.h b/test/kvx/interop/common.h new file mode 100644 index 00000000..055ce7ea --- /dev/null +++ b/test/kvx/interop/common.h @@ -0,0 +1,28 @@ +#ifndef __COMMON_H__ +#define __COMMON_H__ + +void void_void(void); + +long long ll_void(void); + +int i_oneiarg(int arg); + +int i_multiiargs(int arg1, char arg2, char arg3, int arg4); + +int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, + char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, + char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29); + +int ll_onellarg(long long arg); + +long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4); + +long long ll_manyllargs(char a0, long long a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, + char a10, long long a11, char a12, long long a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, + char a20, long long a21, char a22, long long a23, char a24, char a25, long long a26, long long a27, char a28, long long a29); + +double stackhell(char a0, long long a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, + char a10, long long a11, char a12, long long a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, + char a20, long long a21, char a22, long long a23, char a24, char a25, long long a26, long long a27, char a28, long long a29); + +#endif diff --git a/test/kvx/interop/framework.h b/test/kvx/interop/framework.h new file mode 100644 index 00000000..3bbfa271 --- /dev/null +++ b/test/kvx/interop/framework.h @@ -0,0 +1,66 @@ +#ifndef __FRAMEWORK_H__ +#define __FRAMEWORK_H__ + +#include +#include "../prng/prng.c" + +#define BEGIN_TEST_N(type, N)\ + int main(void){\ + type t[N], c, i, j, S;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + for (j = 0 ; j < N ; j++)\ + t[j] = randlong();\ + /* END BEGIN_TEST_N */ + +#define BEGIN_TEST(type)\ + int main(void){\ + type a, b, c, S;\ + int i;\ + srand(0);\ + S = 0;\ + for (i = 0 ; i < 100 ; i++){\ + c = randlong();\ + a = randlong();\ + b = randlong(); + /* END BEGIN_TEST */ + +/* In between BEGIN_TEST and END_TEST : definition of c */ + +#define END_TEST64()\ + printf("%llu\t%llu\t%llu\n", a, b, c);\ + S += c;\ + }\ + return S;\ + } + /* END END_TEST64 */ + +#define END_TEST32()\ + printf("%u\t%u\t%u\n", a, b, c);\ + S += c;\ + }\ + return S;\ + } + /* END END_TEST32 */ + +#define END_TESTF32()\ + printf("%e\t%e\t%e\n", a, b, c);\ + S += c;\ + }\ + return 0;\ + } + /* END END_TESTF32 */ + +#define END_TESTF64()\ + printf("%e\t%e\t%e\n", a, b, c);\ + S += c;\ + }\ + return 0;\ + } + /* END END_TESTF64 */ + +#endif + + diff --git a/test/kvx/interop/i32.c b/test/kvx/interop/i32.c new file mode 100644 index 00000000..6bc2705c --- /dev/null +++ b/test/kvx/interop/i32.c @@ -0,0 +1,13 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(int) + c = i_manyiargs(a, b, a-b, a+b, a*2, b*2, a*2-b, a+b*2, (a-b)*2, (a+b)*2, + -2*a, -2*b, a-b, a+b, a*3, b*3, a*3-b, a+b*3, (a-b)*3, (a+b)*3, + -3*a, -3*b, a-b, a+b, a*4, b*4, a*4-b, a+b*4, (a-b)*4, (a+b)*4); + c += i_multiiargs(a, b, a-b, a+b); + c += i_oneiarg(a); + void_void(); + c += a; +END_TEST32() + diff --git a/test/kvx/interop/i64.c b/test/kvx/interop/i64.c new file mode 100644 index 00000000..3e7240f7 --- /dev/null +++ b/test/kvx/interop/i64.c @@ -0,0 +1,14 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(long long) + c = ll_manyllargs(a, b, a-b, a+b, a*2, b*2, a*2-b, a+b*2, (a-b)*2, (a+b)*2, + -2*a, -2*b, a-b, a+b, a*3, b*3, a*3-b, a+b*3, (a-b)*3, (a+b)*3, + -3*a, -3*b, a-b, a+b, a*4, b*4, a*4-b, a+b*4, (a-b)*4, (a+b)*4); + c += ll_multillargs(a, b, a-b, a+b); + c += ll_onellarg(a); + c = ll_void(); + c += a; + void_void(); + c += a; +END_TEST64() diff --git a/test/kvx/interop/individual/i_multiiargs.c b/test/kvx/interop/individual/i_multiiargs.c new file mode 100644 index 00000000..888742b5 --- /dev/null +++ b/test/kvx/interop/individual/i_multiiargs.c @@ -0,0 +1,6 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(int) + c = i_multiiargs(a, b, a-b, a+b); +END_TEST32() diff --git a/test/kvx/interop/individual/i_oneiarg.c b/test/kvx/interop/individual/i_oneiarg.c new file mode 100644 index 00000000..9c969fb8 --- /dev/null +++ b/test/kvx/interop/individual/i_oneiarg.c @@ -0,0 +1,6 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(int) + c = i_oneiarg(a); +END_TEST32() diff --git a/test/kvx/interop/individual/ll_multillargs.c b/test/kvx/interop/individual/ll_multillargs.c new file mode 100644 index 00000000..34b422eb --- /dev/null +++ b/test/kvx/interop/individual/ll_multillargs.c @@ -0,0 +1,7 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(long long) + c = ll_multillargs(a, b, a-b, a+b); +END_TEST64() + diff --git a/test/kvx/interop/individual/ll_onellarg.c b/test/kvx/interop/individual/ll_onellarg.c new file mode 100644 index 00000000..a2fbbbe9 --- /dev/null +++ b/test/kvx/interop/individual/ll_onellarg.c @@ -0,0 +1,7 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(long long) + c = ll_onellarg(a); +END_TEST64() + diff --git a/test/kvx/interop/individual/ll_void.c b/test/kvx/interop/individual/ll_void.c new file mode 100644 index 00000000..da128fdd --- /dev/null +++ b/test/kvx/interop/individual/ll_void.c @@ -0,0 +1,7 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(long long) + c = ll_void(); + c += a; +END_TEST64() diff --git a/test/kvx/interop/individual/void_void.c b/test/kvx/interop/individual/void_void.c new file mode 100644 index 00000000..976a721b --- /dev/null +++ b/test/kvx/interop/individual/void_void.c @@ -0,0 +1,7 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(long long) + void_void(); + c = a; +END_TEST64() diff --git a/test/kvx/interop/stackhell.c b/test/kvx/interop/stackhell.c new file mode 100644 index 00000000..5abaa71d --- /dev/null +++ b/test/kvx/interop/stackhell.c @@ -0,0 +1,9 @@ +#include "framework.h" +#include "common.h" + +BEGIN_TEST(double) + c = stackhell(a, b, a*b, a*b, a*2, b*2, a*2*b, a*b*2, (a*b)*2, (a*b)*2, + 2*a, 2*b, a*b, a*b, a*3, b*3, a*3*b, a*b*3, (a*b)*3, (a*b)*3, + 3*a, 3*b, a*b, a*b, a*4, b*4, a*4*b, a*b*4, (a*b)*4, (a*b)*4); + +END_TESTF64() diff --git a/test/kvx/interop/vaarg_common.c b/test/kvx/interop/vaarg_common.c new file mode 100644 index 00000000..3314959f --- /dev/null +++ b/test/kvx/interop/vaarg_common.c @@ -0,0 +1,383 @@ +#include + +#define STACK int a[100];\ + a[42] = 42; + +#define ONEARG_OP(arg) (3*magic(arg)+2) + +#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4) + +#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\ + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\ + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\ + (a0 + a1 * a2 + magic(a3) * a4 + a5 + a6 + a7 - a8 + a9 +\ + a10 + a11 - a12 ^ a13 + a14 - magic(a15) + a16 ^ a17 + a18 + a19 +\ + a20 + a21 + a22 * a23 + a24 + a25 << a26 & a27 + a28 + a29) + +#define VA_START(vl, arg) va_list vl; va_start(vl, arg) +#define VA_END(vl) va_end(vl) + +int magic(long a){ + return a*2 + 42; +} + +void void_void(void){ + STACK; +} + +long long ll_void(void){ + STACK; + return 0xdeadbeefdeadbeefULL; +} + +// int i_oneiarg(int arg){ +int i_oneiarg(int arg, ...){ + STACK; + VA_START(vl, arg); + VA_END(vl); + return ONEARG_OP(arg); +} + +//int i_multiiargs(int arg1, char arg2, char arg3, int arg4){ +int i_multiiargs(int arg1, ...){ + STACK; + VA_START(vl, arg1); + char arg2 = va_arg(vl, int); + char arg3 = va_arg(vl, int); + int arg4 = va_arg(vl, int); + VA_END(vl); + return MULTIARG_OP(arg1, arg2, arg3, arg4); +} + +//int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, +// char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, +// char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29) +int i_manyiargs(char a0, ...) +{ + STACK; + VA_START(vl, a0); + VA_START(vl2, a0); + int a1 = va_arg(vl, int); + char a2 = va_arg(vl, int); + int a3 = va_arg(vl, int); + char a4 = va_arg(vl, int); + char a5 = va_arg(vl, int); + char b1 = va_arg(vl2, int); + int a6 = va_arg(vl, int); + int a7 = va_arg(vl, int); + char a8 = va_arg(vl, int); + char b2 = va_arg(vl2, int); + int a9 = va_arg(vl, int); + char a10 = va_arg(vl, int); + int a11 = va_arg(vl, int); + char a12 = va_arg(vl, int); + char b3 = va_arg(vl2, int); + int a13 = va_arg(vl, int); + char a14 = va_arg(vl, int); + char a15 = va_arg(vl, int); + int a16 = va_arg(vl, int); + int a17 = va_arg(vl, int); + char a18 = va_arg(vl, int); + int a19 = va_arg(vl, int); + char a20 = va_arg(vl, int); + int a21 = va_arg(vl, int); + char a22 = va_arg(vl, int); + int a23 = va_arg(vl, int); + char a24 = va_arg(vl, int); + char a25 = va_arg(vl, int); + int a26 = va_arg(vl, int); + char b4 = va_arg(vl2, int); + int a27 = va_arg(vl, int); + char a28 = va_arg(vl, int); + int a29 = va_arg(vl, int); + VA_END(vl); + VA_END(vl); + return MANYARG_OP(a0, a1, a2, a3, a4, (a5*b2), a6, a7, a8, a9, + (a10*b3), a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, (a21*b1), a22, a23, (a24*b3), a25, a26, a27, a28, a29); +} + +//int ll_onellarg(long long arg){ +int ll_onellarg(long long arg, ...){ + STACK; + VA_START(vl, arg); + VA_END(vl); + return ONEARG_OP(arg); +} + +//long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4){ +long long ll_multillargs(long long arg1, ...){ + STACK; + VA_START(vl, arg1); + char arg2 = va_arg(vl, int); + char arg3 = va_arg(vl, int); + long long arg4 = va_arg(vl, long long); + VA_END(vl); + return MULTIARG_OP(arg1, arg2, arg3, arg4); +} + +//long long ll_manyllargs(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, +// char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, +// char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) +long long ll_manyllargs(char a0, ...) +{ + STACK; + VA_START(vl, a0); + int a1 = va_arg(vl, int); + char a2 = va_arg(vl, int); + long long a3 = va_arg(vl, long long); + char a4 = va_arg(vl, int); + char a5 = va_arg(vl, int); + long long a6 = va_arg(vl, long long); + long long a7 = va_arg(vl, long long); + char a8 = va_arg(vl, int); + long long a9 = va_arg(vl, long long); + char a10 = va_arg(vl, int); + long long a11 = va_arg(vl, long long); + char a12 = va_arg(vl, int); + int a13 = va_arg(vl, int); + char a14 = va_arg(vl, int); + char a15 = va_arg(vl, int); + long long a16 = va_arg(vl, long long); + long long a17 = va_arg(vl, long long); + char a18 = va_arg(vl, int); + long long a19 = va_arg(vl, long long); + char a20 = va_arg(vl, int); + int a21 = va_arg(vl, int); + char a22 = va_arg(vl, int); + long long a23 = va_arg(vl, long long); + char a24 = va_arg(vl, int); + char a25 = va_arg(vl, int); + long long a26 = va_arg(vl, long long); + int a27 = va_arg(vl, int); + char a28 = va_arg(vl, int); + long long a29 = va_arg(vl, long long); + VA_END(vl); + return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); +} + +//long long stackhell(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, +// char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, +// char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) +long long stackhell(char a0, ...) +{ + VA_START(vl, a0); + int a1 = va_arg(vl, int); + char a2 = va_arg(vl, int); + long long a3 = va_arg(vl, long long); + char a4 = va_arg(vl, int); + char a5 = va_arg(vl, int); + long long a6 = va_arg(vl, long long); + long long a7 = va_arg(vl, long long); + char a8 = va_arg(vl, int); + long long a9 = va_arg(vl, long long); + char a10 = va_arg(vl, int); + long long a11 = va_arg(vl, long long); + char a12 = va_arg(vl, int); + int a13 = va_arg(vl, int); + char a14 = va_arg(vl, int); + char a15 = va_arg(vl, int); + long long a16 = va_arg(vl, long long); + long long a17 = va_arg(vl, long long); + char a18 = va_arg(vl, int); + long long a19 = va_arg(vl, long long); + char a20 = va_arg(vl, int); + int a21 = va_arg(vl, int); + char a22 = va_arg(vl, int); + long long a23 = va_arg(vl, long long); + char a24 = va_arg(vl, int); + char a25 = va_arg(vl, int); + long long a26 = va_arg(vl, long long); + int a27 = va_arg(vl, int); + char a28 = va_arg(vl, int); + long long a29 = va_arg(vl, long long); + VA_END(vl); + + long long b0 = a0; + long long b1 = a1 + b0; + long long b2 = a2 + b1; + int b3 = a3 + b2; + int b4 = a4 + b3; + int b5 = a5 + b4; + int b6 = a6 + b5; + int b7 = a7 + b6; + char b8 = a8 + b7; + char b9 = a9 + b8; + char b10 = a10 + b9; + char b11 = a11 + b10; + char b12 = a12 + b11; + int b13 = a13 + b12; + long long b14 = a14 + b13; + long long b15 = a15 + b14; + long long b16 = a16 + b15; + long long b17 = a17 + b16; + long long b18 = a18 + b17; + long long b19 = a19 + b18; + long long b20 = a20 + b19; + long long b21 = a21 + b20; + long long b22 = a22 + b21; + long long b23 = a23 + b22; + long long b24 = a24 + b23; + long long b25 = a25 + b24; + long long b26 = a26 + b25; + long long b27 = a27 + b26; + int b28 = a28 + b27; + int b29 = a29 + b28; + int b30 = b0 + b29; + int b31 = b1 + b30; + int b32 = b2 + b31; + char b33 = b3 + b32; + char b34 = b4 + b33; + char b35 = b5 + b34; + char b36 = b6 + b35; + char b37 = b7 + b36; + int b38 = b8 + b37; + int b39 = b9 + b38; + int b40 = b0 + b39; + int b41 = b1 + b40; + int b42 = b2 + b41; + int b43 = b3 + b42; + int b44 = b4 + b43; + int b45 = b5 + b44; + int b46 = b6 + b45; + int b47 = b7 + b46; + int b48 = b8 + b47; + long long b49 = b9 + b48; + long long b50 = b0 + b49; + long long b51 = b1 + b50; + long long b52 = b2 + b51; + long long b53 = b3 + b52; + long long b54 = b4 + b53; + long long b55 = b5 + b54; + long long b56 = b6 + b55; + long long b57 = b7 + b56; + int b58 = b8 + b57; + int b59 = b9 + b58; + int b60 = b0 + b59; + int b61 = b1 + b60; + int b62 = b2 + b61; + int b63 = b3 + b62; + int b64 = b4 + b63; + int b65 = b5 + b64; + int b66 = b6 + b65; + int b67 = b7 + b66; + int b68 = b8 + b67; + int b69 = b9 + b68; + char b70 = b0 + b69; + char b71 = b1 + b70; + char b72 = b2 + b71; + char b73 = b3 + b72; + char b74 = b4 + b73; + char b75 = b5 + b74; + char b76 = b6 + b75; + char b77 = b7 + b76; + char b78 = b8 + b77; + char b79 = b9 + b78; + char b80 = b0 + b79; + char b81 = b1 + b80; + char b82 = b2 + b81; + char b83 = b3 + b82; + char b84 = b4 + b83; + int b85 = b5 + b84; + int b86 = b6 + b85; + int b87 = b7 + b86; + int b88 = b8 + b87; + int b89 = b9 + b88; + int b90 = b0 + b89; + int b91 = b1 + b90; + int b92 = b2 + b91; + int b93 = b3 + b92; + int b94 = b4 + b93; + long long b95 = b5 + b94; + long long b96 = b6 + b95; + long long b97 = b7 + b96; + long long b98 = b8 + b97; + long long b99 = b9 + b98; + long long b100 = b0 + b99; + long long b101 = b1 + b100; + long long b102 = b2 + b101; + long long b103 = b3 + b102; + long long b104 = b4 + b103; + long long b105 = b5 + b104; + long long b106 = b6 + b105; + long long b107 = b7 + b106; + long long b108 = b8 + b107; + long long b109 = b9 + b108; + long long b110 = b0 + b109; + long long b111 = b1 + b110; + long long b112 = b2 + b111; + long long b113 = b3 + b112; + long long b114 = b4 + b113; + int b115 = b5 + b114; + int b116 = b6 + b115; + int b117 = b7 + b116; + int b118 = b8 + b117; + int b119 = b9 + b118; + int b120 = b0 + b119; + int b121 = b1 + b120; + int b122 = b2 + b121; + int b123 = b3 + b122; + int b124 = b4 + b123; + int b125 = b5 + b124; + char b126 = b6 + b125; + char b127 = b7 + b126; + char b128 = b8 + b127; + char b129 = b9 + b128; + char b130 = b0 + b129; + char b131 = b1 + b130; + char b132 = b2 + b131; + char b133 = b3 + b132; + char b134 = b4 + b133; + char b135 = b5 + b134; + char b136 = b6 + b135; + char b137 = b7 + b136; + char b138 = b8 + b137; + char b139 = b9 + b138; + char b140 = b0 + b139; + char b141 = b1 + b140; + char b142 = b2 + b141; + char b143 = b3 + b142; + char b144 = b4 + b143; + char b145 = b5 + b144; + char b146 = b6 + b145; + char b147 = b7 + b146; + int b148 = b8 + b147; + int b149 = b9 + b148; + int b150 = b0 + b149; + int b151 = b1 + b150; + int b152 = b2 + b151; + int b153 = b3 + b152; + int b154 = b4 + b153; + int b155 = b5 + b154; + int b156 = b6 + b155; + int b157 = b7 + b156; + int b158 = b8 + b157; + int b159 = b9 + b158; + int b160 = b0 + b159; + int b161 = b1 + b160; + int b162 = b2 + b161; + return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) + + b0 + b1 + b2 + b3 + b4 + b5 + b6 + b7 + b8 + b9 + + b10 + b11 + b12 + b13 + b14 + b15 + b16 + b17 + b18 + b19 + + b20 + b21 + b22 + b23 + b24 + b25 + b26 + b27 + b28 + b29 + + b30 + b31 + b32 + b33 + b34 + b35 + b36 + b37 + b38 + b39 + + b40 + b41 + b42 + b43 + b44 + b45 + b46 + b47 + b48 + b49 + + b50 + b51 + b52 + b53 + b54 + b55 + b56 + b57 + b58 + b59 + + b60 + b61 + b62 + b63 + b64 + b65 + b66 + b67 + b68 + b69 + + b70 + b71 + b72 + b73 + b74 + b75 + b76 + b77 + b78 + b79 + + b80 + b81 + b82 + b83 + b84 + b85 + b86 + b87 + b88 + b89 + + b90 + b91 + b92 + b93 + b94 + b95 + b96 + b97 + b98 + b99 + + b100 + b101 + b102 + b103 + b104 + b105 + b106 + b107 + b108 + b109 + + b110 + b111 + b112 + b113 + b114 + b115 + b116 + b117 + b118 + b119 + + b120 + b121 + b122 + b123 + b124 + b125 + b126 + b127 + b128 + b129 + + b130 + b131 + b132 + b133 + b134 + b135 + b136 + b137 + b138 + b139 + + b140 + b141 + b142 + b143 + b144 + b145 + b146 + b147 + b148 + b149 + + b150 + b151 + b152 + b153 + b154 + b155 + b156 + b157 + b158 + b159 + + b160 + b161 + b162 + ; +} + diff --git a/test/kvx/lib/Makefile b/test/kvx/lib/Makefile new file mode 100644 index 00000000..5a947bb3 --- /dev/null +++ b/test/kvx/lib/Makefile @@ -0,0 +1,133 @@ +KVXC ?= k1-cos-gcc +K1AR ?= k1-cos-ar +CC ?= gcc +AR ?= gcc-ar +CCOMP ?= ccomp +CFLAGS ?= -O1 -Wl,--wrap=printf +SIMU ?= k1-mppa +TIMEOUT ?= --signal=SIGTERM 60s + +DIR=./ +SRCDIR=$(DIR) +OUTDIR=$(DIR)/out +BINDIR=$(DIR)/bin +ASMDIR=$(DIR)/asm +OBJDIR=$(DIR)/obj + +KVXCPATH=$(shell which $(KVXC)) +K1ARPATH=$(shell which $(K1AR)) +CCPATH=$(shell which $(CC)) +ARPATH=$(shell which $(AR)) +SIMUPATH=$(shell which $(SIMU)) + +TESTNAMES=printf-test +X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) +GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES))) +CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES))) + +OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT) +BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ + $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES))) + +## +# Targets +## + +all: $(BIN) system.x86-gcc.a system.gcc.a + +.PHONY: +test: $(X86_GCC_OUT) $(GCC_OUT) + @echo "Comparing x86 gcc output to k1 gcc.." + @for test in $(TESTNAMES); do\ + x86out=$(OUTDIR)/$$test.x86-gcc.out;\ + gccout=$(OUTDIR)/$$test.gcc.out;\ + if ! diff $$x86out $$gccout; then\ + >&2 echo "ERROR: $$x86out and $$gccout differ";\ + else\ + echo "GOOD: $$x86out and $$gccout concur";\ + fi;\ + done + +.PHONY: +check: $(GCC_OUT) $(CCOMP_OUT) + @echo "Comparing k1 gcc output to ccomp.." + @for test in $(TESTNAMES); do\ + gccout=$(OUTDIR)/$$test.gcc.out;\ + ccompout=$(OUTDIR)/$$test.ccomp.out;\ + if ! diff $$ccompout $$gccout; then\ + >&2 echo "ERROR: $$ccompout and $$gccout differ";\ + else\ + echo "GOOD: $$ccompout and $$gccout concur";\ + fi;\ + done + +## +# Rules +## + +.SECONDARY: + +# Generating output + +## Version avec timeout +$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) + @mkdir -p $(@D) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +# Object to binary + +$(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o system.x86-gcc.a $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o system.gcc.a $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ + +$(BINDIR)/%.ccomp.bin: $(OBJDIR)/%.ccomp.o system.gcc.a $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +# Generating libraries +system.x86-gcc.a: $(OBJDIR)/printf.x86-gcc.o $(ARPATH) + $(AR) rcs $@ $< + +system.gcc.a: $(OBJDIR)/printf.gcc.o $(K1ARPATH) + $(K1AR) rcs $@ $< + +# Assembly to object + +$(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) -c $< -o $@ + +$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) -c $< -o $@ + +$(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) + $(CCOMP) $(CFLAGS) -c $< -o $@ + +# Source to assembly + +$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) + @mkdir -p $(@D) + $(CC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) + @mkdir -p $(@D) + $(KVXC) $(CFLAGS) -S $< -o $@ + +$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) + @mkdir -p $(@D) + $(CCOMP) $(CFLAGS) -S $< -o $@ + diff --git a/test/kvx/lib/printf-test.c b/test/kvx/lib/printf-test.c new file mode 100644 index 00000000..25afd436 --- /dev/null +++ b/test/kvx/lib/printf-test.c @@ -0,0 +1,9 @@ +int printf(const char *, ...); + +int main(void){ + int a = 42; + char *str = "Hi there"; + printf("%s, I am %u\n", str, a); + + return 0; +} diff --git a/test/kvx/lib/printf.c b/test/kvx/lib/printf.c new file mode 100644 index 00000000..79984ef6 --- /dev/null +++ b/test/kvx/lib/printf.c @@ -0,0 +1,9 @@ +#include +#include + +int __wrap_printf(const char *format, ...){ + va_list args; + va_start(args, format); + vprintf(format, args); + va_end(args); +} diff --git a/test/kvx/mmult/.gitignore b/test/kvx/mmult/.gitignore new file mode 100644 index 00000000..b43ccc5f --- /dev/null +++ b/test/kvx/mmult/.gitignore @@ -0,0 +1,4 @@ +mmult-test-ccomp-kvx +mmult-test-gcc-kvx +mmult-test-gcc-x86 +.zero diff --git a/test/kvx/mmult/Makefile b/test/kvx/mmult/Makefile new file mode 100644 index 00000000..e7cd890e --- /dev/null +++ b/test/kvx/mmult/Makefile @@ -0,0 +1,67 @@ +KVXC ?= k1-cos-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-mppa +TIMEOUT ?= 10s + +KVXCPATH=$(shell which $(KVXC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +PRNG=../prng/prng.c + +ALL= mmult-test-gcc-x86 mmult-test-gcc-kvx mmult-test-ccomp-kvx +CCOMP_OUT= mmult-test-ccomp-kvx.out +GCC_OUT= mmult-test-gcc-kvx.out +X86_GCC_OUT= mmult-test-gcc-x86.out +STUB_OUT=.zero + +all: $(ALL) + +mmult-test-gcc-x86: mmult.c $(PRNG) $(CCPATH) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +mmult-test-gcc-kvx: mmult.c $(PRNG) $(KVXCPATH) + $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ + +mmult-test-ccomp-kvx: mmult.c $(PRNG) $(CCOMPPATH) + $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +.SECONDARY: +%kvx.out: %kvx $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test: test-x86 test-kvx + +.PHONY: +test-x86: $(X86_GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR x86: $< failed";\ + else\ + echo "GOOD x86: $< succeeded";\ + fi + +.PHONY: +test-kvx: $(GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $< failed";\ + else\ + echo "GOOD kvx: $< succeeded";\ + fi + +.PHONY: +check: $(CCOMP_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $< failed";\ + else\ + echo "GOOD kvx: $< succeeded";\ + fi diff --git a/test/kvx/mmult/README.md b/test/kvx/mmult/README.md new file mode 100644 index 00000000..780603f6 --- /dev/null +++ b/test/kvx/mmult/README.md @@ -0,0 +1,17 @@ +MMULT +===== + +Examples of matrix multiplication using different methods. + +We compute matrix multiplication using column-based matrix multiplication, then row-based, and finally block based. + +The test verifies that the result is the same on the three methods. If it is the same, 0 will be returned. + +The following commands can be run inside the folder: + +- `make`: produces the unitary test binaries + - `mmult-test-gcc-x86` : binary from gcc on x86 + - `mmult-test-kvx-x86` : binary from gcc on kvx + - `mmult-test-ccomp-x86` : binary from ccomp on kvx +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/kvx/mmult/mmult.c b/test/kvx/mmult/mmult.c new file mode 100644 index 00000000..aeb91d48 --- /dev/null +++ b/test/kvx/mmult/mmult.c @@ -0,0 +1,146 @@ +#include "../prng/types.h" +#include "../prng/prng.h" + +#define __UNIT_TEST_MMULT__ + +#ifdef __UNIT_TEST_MMULT__ +#define SIZE 10 +#else +#include "test.h" +#endif + +void mmult_row(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + int i, j, k; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] = 0; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + for (k = 0 ; k < SIZE ; k++) + C[i][j] += A[i][k] * B[k][j]; +} + +void mmult_col(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + int i, j, k; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] = 0; + + for (k = 0 ; k < SIZE ; k++) + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + C[i][j] += A[i][k] * B[k][j]; +} + +typedef struct mblock { + int imin, imax, jmin, jmax; + uint64_t *mat; +} mblock; + +#define MAT_XY(mat, x, y) (mat)[(x)*SIZE + (y)] +#define MAT_IJ(block, i, j) MAT_XY((block)->mat, (block)->imin + (i), block->jmin + (j)) + +void divac_mul(mblock *C, const mblock *A, const mblock *B){ + const int size = C->imax - C->imin; + int i, j, k; + + for (i = 0 ; i < size ; i++) + for (j = 0 ; j < size ; j++) + for (k = 0 ; k < size ; k++) + MAT_IJ(C, i, j) += MAT_IJ(A, i, k) * MAT_IJ(B, k, j); +} + +#define BLOCK_X_MID(block) ((block)->imin + (block)->imax) / 2 +#define BLOCK_Y_MID(block) ((block)->jmin + (block)->jmax) / 2 + +#define MAKE_MBLOCK(newb, block, I, J) \ + mblock newb = {.mat=(block)->mat};\ + if ((I) == 0){\ + newb.imin = (block)->imin;\ + newb.imax = BLOCK_X_MID((block));\ + } else {\ + newb.imin = BLOCK_X_MID((block));\ + newb.imax = (block)->imax;\ + } if ((J) == 0){\ + newb.jmin = (block)->jmin;\ + newb.jmax = BLOCK_Y_MID((block));\ + } else {\ + newb.jmin = BLOCK_Y_MID((block));\ + newb.jmax = (block)->jmax;\ + } + +void divac_part(mblock *C, const mblock *A, const mblock *B); + +void divac_wrap(mblock *C , char IC, char JC, + const mblock *A, char IA, char JA, + const mblock *B, char IB, char JB){ + MAKE_MBLOCK(Cb, C, IC, JC); + MAKE_MBLOCK(Ab, A, IA, JA); + MAKE_MBLOCK(Bb, B, IB, JB); + + divac_part(&Cb, &Ab, &Bb); +} + + +void divac_part(mblock *C, const mblock *A, const mblock *B){ + const int size = C->imax - C->imin; + + if (size % 2 == 1) + divac_mul(C, A, B); + else{ + /* C_00 = A_00 B_00 + A_01 B_10 */ + divac_wrap(C, 0, 0, A, 0, 0, B, 0, 0); + divac_wrap(C, 0, 0, A, 0, 1, B, 1, 0); + + /* C_10 = A_10 B_00 + A_11 B_10 */ + divac_wrap(C, 1, 0, A, 1, 0, B, 0, 0); + divac_wrap(C, 1, 0, A, 1, 1, B, 1, 0); + + /* C_01 = A_00 B_01 + A_01 B_11 */ + divac_wrap(C, 0, 1, A, 0, 0, B, 0, 1); + divac_wrap(C, 0, 1, A, 0, 1, B, 1, 1); + + /* C_11 = A_10 B_01 + A_11 B_11 */ + divac_wrap(C, 1, 1, A, 1, 0, B, 0, 1); + divac_wrap(C, 1, 1, A, 1, 1, B, 1, 1); + } + +} + +void mmult_divac(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ + mblock Cb = {.mat = (uint64_t *) C, .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + mblock Ab = {.mat = (uint64_t *) A , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + mblock Bb = {.mat = (uint64_t *) B , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; + + divac_part(&Cb, &Ab, &Bb); +} + +#ifdef __UNIT_TEST_MMULT__ +static uint64_t C1[SIZE][SIZE], C2[SIZE][SIZE], C3[SIZE][SIZE]; +static uint64_t A[SIZE][SIZE], B[SIZE][SIZE]; + +int main(void){ + srand(42); + int i, j; + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++){ + A[i][j] = randlong(); + B[i][j] = randlong(); + } + + mmult_row(C1, A, B); + mmult_col(C2, A, B); + mmult_divac(C3, A, B); + + for (i = 0 ; i < SIZE ; i++) + for (j = 0 ; j < SIZE ; j++) + if (!(C1[i][j] == C2[i][j] && C1[i][j] == C3[i][j])) + return -1; + + return 0; +} +#endif /* __UNIT_TEST_MMULT__ */ diff --git a/test/kvx/mmult/mmult.h b/test/kvx/mmult/mmult.h new file mode 100644 index 00000000..3721784a --- /dev/null +++ b/test/kvx/mmult/mmult.h @@ -0,0 +1,10 @@ +#ifndef __MMULT_H__ +#define __MMULT_H__ + +#include "../lib/types.h" + +void mmult_row(uint64_t *A, const uint64_t *B, const uint64_t *C); +void mmult_column(uint64_t *A, const uint64_t *B, const uint64_t *C); +void mmult_strassen(uint64_t *A, const uint64_t *B, const uint64_t *C); + +#endif /* __MMULT_H__ */ diff --git a/test/kvx/prng/.gitignore b/test/kvx/prng/.gitignore new file mode 100644 index 00000000..08023900 --- /dev/null +++ b/test/kvx/prng/.gitignore @@ -0,0 +1,3 @@ +prng-test-ccomp-kvx +prng-test-gcc-x86 +prng-test-gcc-kvx diff --git a/test/kvx/prng/Makefile b/test/kvx/prng/Makefile new file mode 100644 index 00000000..68e5ffc9 --- /dev/null +++ b/test/kvx/prng/Makefile @@ -0,0 +1,69 @@ +KVXC ?= k1-cos-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-mppa +TIMEOUT ?= 10s + +KVXCPATH=$(shell which $(KVXC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +ALL= prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx +CCOMP_OUT= prng-test-ccomp-kvx.out +GCC_OUT= prng-test-gcc-kvx.out +X86_GCC_OUT= prng-test-gcc-x86.out +STUB_OUT=.zero + +all: $(ALL) + +prng-test-gcc-x86: prng.c $(CCPATH) + $(CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +prng-test-gcc-kvx: prng.c $(KVXCPATH) + $(KVXC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +prng-test-ccomp-kvx: prng.c $(CCOMPPATH) + $(CCOMP) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ + +.SECONDARY: +%kvx.out: %kvx $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test: test-x86 test-kvx + +.PHONY: +test-x86: $(X86_GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR x86: $< failed";\ + else\ + echo "GOOD x86: $< succeeded";\ + fi + +.PHONY: +test-kvx: $(GCC_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $< failed";\ + else\ + echo "GOOD kvx: $< succeeded";\ + fi + +.PHONY: +check: $(CCOMP_OUT) $(STUB_OUT) + @if ! diff $< $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $< failed";\ + else\ + echo "GOOD kvx: $< succeeded";\ + fi + +.PHONY: +clean: + rm -f prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx diff --git a/test/kvx/prng/README.md b/test/kvx/prng/README.md new file mode 100644 index 00000000..98ed539d --- /dev/null +++ b/test/kvx/prng/README.md @@ -0,0 +1,17 @@ +PRNG +==== + +This is a simple Pseudo Random Number Generator. + +`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" +of 1000 generated numbers to a hardcoded result, that is the one obtained with +`gcc -O2` on a x86 processor, and returns 0 if the result is correct. + +The following commands can be run inside that folder: + +- `make`: produces the unitary test binaries + - `prng-test-gcc-x86` : binary from gcc on x86 + - `prng-test-kvx-x86` : binary from gcc on kvx + - `prng-test-ccomp-x86` : binary from ccomp on kvx +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/kvx/prng/prng.c b/test/kvx/prng/prng.c new file mode 100644 index 00000000..71de1dc3 --- /dev/null +++ b/test/kvx/prng/prng.c @@ -0,0 +1,41 @@ +// https://en.wikipedia.org/wiki/Linear_congruential_generator -> MMIX Donald Knuth +// modulo 2^64 = no need to do it explicitly + +#include "types.h" + +#define MULTIPLIER 6364136223846793005LL +#define INCREMENT 1442695040888963407LL + +static uint64_t current; + +void srand(uint64_t seed){ + current = seed; +} + +uint64_t randlong(void){ + return (current = MULTIPLIER * current + INCREMENT); +} + +#ifdef __UNIT_TEST_PRNG__ +char bytewise_sum(uint64_t to_check){ + char sum = 0; + int i; + + for (i = 0 ; i < 8 ; i++) + sum += (to_check & (uint64_t)(0xFFULL << i*8)) >> i*8; + + return sum; +} + +int main(void){ + srand(42); + int i; + + for (i = 0 ; i < 1000 ; i++) + randlong(); + + uint64_t last = randlong(); + + return !((unsigned char)bytewise_sum(last) == 155); +} +#endif // __UNIT_TEST_PRNG__ diff --git a/test/kvx/prng/prng.h b/test/kvx/prng/prng.h new file mode 100644 index 00000000..6abdb45a --- /dev/null +++ b/test/kvx/prng/prng.h @@ -0,0 +1,10 @@ +#ifndef __PRNG_H__ +#define __PRNG_H__ + +#include "types.h" + +void srand(uint64_t seed); + +uint64_t randlong(void); + +#endif // __PRNG_H__ diff --git a/test/kvx/prng/types.h b/test/kvx/prng/types.h new file mode 100644 index 00000000..584023e3 --- /dev/null +++ b/test/kvx/prng/types.h @@ -0,0 +1,7 @@ +#ifndef __TYPES_H__ +#define __TYPES_H__ + +#define uint64_t unsigned long long +#define int64_t signed long long + +#endif // __TYPES_H__ diff --git a/test/kvx/simucheck.sh b/test/kvx/simucheck.sh new file mode 100755 index 00000000..48698e35 --- /dev/null +++ b/test/kvx/simucheck.sh @@ -0,0 +1,8 @@ +#!/bin/bash +# Tests the execution of the binaries produced by CompCert, by simulation + +cores=$(grep -c ^processor /proc/cpuinfo) + +source do_test.sh + +do_test check $cores diff --git a/test/kvx/simutest.sh b/test/kvx/simutest.sh new file mode 100755 index 00000000..729d1ba0 --- /dev/null +++ b/test/kvx/simutest.sh @@ -0,0 +1,8 @@ +#!/bin/bash +# Tests the validity of the tests, in simulator + +cores=$(grep -c ^processor /proc/cpuinfo) + +source do_test.sh + +do_test test $cores diff --git a/test/kvx/sort/.gitignore b/test/kvx/sort/.gitignore new file mode 100644 index 00000000..070b87c4 --- /dev/null +++ b/test/kvx/sort/.gitignore @@ -0,0 +1,9 @@ +main-test-ccomp-kvx +main-test-gcc-kvx +main-test-gcc-x86 +merge-test-gcc-kvx +merge-test-gcc-x86 +selection-test-gcc-kvx +selection-test-gcc-x86 +insertion-test-gcc-kvx +insertion-test-gcc-x86 diff --git a/test/kvx/sort/Makefile b/test/kvx/sort/Makefile new file mode 100644 index 00000000..c4090352 --- /dev/null +++ b/test/kvx/sort/Makefile @@ -0,0 +1,91 @@ +KVXC ?= k1-cos-gcc +CC ?= gcc +CCOMP ?= ccomp +CFLAGS ?= -O2 +SIMU ?= k1-mppa +TIMEOUT ?= 10s + +KVXCPATH=$(shell which $(KVXC)) +CCPATH=$(shell which $(CC)) +CCOMPPATH=$(shell which $(CCOMP)) +SIMUPATH=$(shell which $(SIMU)) + +PRNG=../prng/prng.c + +CFILES=insertion.c merge.c selection.c main.c + +ALL= insertion-gcc-x86 insertion-gcc-kvx insertion-ccomp-kvx\ + selection-gcc-x86 selection-gcc-kvx selection-ccomp-kvx\ + merge-gcc-x86 merge-gcc-kvx merge-ccomp-kvx\ + main-gcc-x86 main-gcc-kvx main-ccomp-kvx + +CCOMP_OUT= insertion-ccomp-kvx.out selection-ccomp-kvx.out merge-ccomp-kvx.out\ + main-ccomp-kvx.out +GCC_OUT= insertion-gcc-kvx.out selection-gcc-kvx.out merge-gcc-kvx.out\ + main-gcc-kvx.out +X86_GCC_OUT= insertion-gcc-x86.out selection-gcc-x86.out merge-gcc-x86.out\ + main-gcc-x86.out +STUB_OUT= .zero + +all: $(ALL) + +main-gcc-x86: $(CFILES) $(PRNG) $(CCPATH) + $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +%-gcc-x86: %.c $(PRNG) $(CCPATH) + $(CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +main-gcc-kvx: $(CFILES) $(PRNG) $(CCPATH) + $(KVXC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ + +%-gcc-kvx: %.c $(PRNG) $(KVXCPATH) + $(KVXC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ + +main-ccomp-kvx: $(CFILES) $(PRNG) $(CCOMPPATH) + $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +%-ccomp-kvx: %.c $(PRNG) $(CCOMPPATH) + $(CCOMP) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ + +.SECONDARY: +%x86.out: %x86 + ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ + +%kvx.out: %kvx $(SIMUPATH) + ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ + +.zero: + @echo "0" > $@ + +.PHONY: +test-x86: $(STUB_OUT) $(X86_GCC_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR x86: $$test failed";\ + else\ + echo "GOOD x86: $$test succeeded";\ + fi;\ + done + +.PHONY: +test-kvx: $(STUB_OUT) $(GCC_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $$test failed";\ + else\ + echo "GOOD kvx: $$test succeeded";\ + fi;\ + done + +.PHONY: +test: test-x86 test-kvx + +.PHONY: +check: $(STUB_OUT) $(CCOMP_OUT) + @for test in $(wordlist 2,100,$^); do\ + if ! diff $$test $(STUB_OUT); then\ + >&2 echo "ERROR kvx: $$test failed";\ + else\ + echo "GOOD kvx: $$test succeeded";\ + fi;\ + done diff --git a/test/kvx/sort/README.md b/test/kvx/sort/README.md new file mode 100644 index 00000000..98ed539d --- /dev/null +++ b/test/kvx/sort/README.md @@ -0,0 +1,17 @@ +PRNG +==== + +This is a simple Pseudo Random Number Generator. + +`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" +of 1000 generated numbers to a hardcoded result, that is the one obtained with +`gcc -O2` on a x86 processor, and returns 0 if the result is correct. + +The following commands can be run inside that folder: + +- `make`: produces the unitary test binaries + - `prng-test-gcc-x86` : binary from gcc on x86 + - `prng-test-kvx-x86` : binary from gcc on kvx + - `prng-test-ccomp-x86` : binary from ccomp on kvx +- `make test`: tests the return value of the binaries produced by gcc. +- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/kvx/sort/insertion.c b/test/kvx/sort/insertion.c new file mode 100644 index 00000000..bca09599 --- /dev/null +++ b/test/kvx/sort/insertion.c @@ -0,0 +1,59 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#ifdef __UNIT_TEST_INSERTION__ +#define SIZE 100 +#else +#include "test.h" +#endif + +void swap_ins(uint64_t *a, uint64_t *b){ + uint64_t tmp = *a; + *a = *b; + *b = tmp; +} + +int insert_sort(uint64_t *res, const uint64_t *T){ + int i, j; + + if (SIZE <= 0) + return -1; + + for (i = 0 ; i < SIZE ; i++) + res[i] = T[i]; + + for (i = 0 ; i < SIZE-1 ; i++){ + if (res[i] > res[i+1]){ + swap_ins(&res[i], &res[i+1]); + for (j = i ; j > 0 ; j--) + if (res[j-1] > res[j]) + swap_ins(&res[j-1], &res[j]); + } + } + + return 0; +} + +#ifdef __UNIT_TEST_INSERTION__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (insert_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + uint64_t max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_INSERTION__ diff --git a/test/kvx/sort/insertion.h b/test/kvx/sort/insertion.h new file mode 100644 index 00000000..6e37c5fe --- /dev/null +++ b/test/kvx/sort/insertion.h @@ -0,0 +1,6 @@ +#ifndef __INSERTION_H__ +#define __INSERTION_H__ + +int insert_sort(uint64_t *res, const uint64_t *T); + +#endif // __INSERTION_H__ diff --git a/test/kvx/sort/main.c b/test/kvx/sort/main.c new file mode 100644 index 00000000..aef419aa --- /dev/null +++ b/test/kvx/sort/main.c @@ -0,0 +1,34 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#include "test.h" +#include "insertion.h" +#include "selection.h" +#include "merge.h" + +int main(void){ + uint64_t T[SIZE]; + uint64_t res1[SIZE], res2[SIZE], res3[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* insertion sort */ + if (insert_sort(res1, T) < 0) return -1; + + /* selection sort */ + if (select_sort(res2, T) < 0) return -2; + + /* merge sort */ + if (merge_sort(res3, T) < 0) return -3; + + /* We should have: res1[i] == res2[i] == res3[i] */ + for (i = 0 ; i < SIZE ; i++){ + if (!(res1[i] == res2[i] && res2[i] == res3[i])) + return -4; + } + + return 0; +} diff --git a/test/kvx/sort/merge.c b/test/kvx/sort/merge.c new file mode 100644 index 00000000..99f8ba85 --- /dev/null +++ b/test/kvx/sort/merge.c @@ -0,0 +1,92 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +//https://en.wikipedia.org/wiki/Merge_sort + +#ifdef __UNIT_TEST_MERGE__ +#define SIZE 100 +#else +#include "test.h" +#endif + +int min(int a, int b){ + return (a < b)?a:b; +} + +void BottomUpMerge(const uint64_t *A, int iLeft, int iRight, int iEnd, uint64_t *B) +{ + int i = iLeft, j = iRight, k; + for (k = iLeft; k < iEnd; k++) { + if (i < iRight && (j >= iEnd || A[i] <= A[j])) { + B[k] = A[i]; + i = i + 1; + } else { + B[k] = A[j]; + j = j + 1; + } + } +} + +void CopyArray(uint64_t *to, const uint64_t *from) +{ + const int n = SIZE; + int i; + + for(i = 0; i < n; i++) + to[i] = from[i]; +} + +void BottomUpMergeSort(uint64_t *A, uint64_t *B) +{ + const int n = SIZE; + int width, i; + + for (width = 1; width < n; width = 2 * width) + { + for (i = 0; i < n; i = i + 2 * width) + { + BottomUpMerge(A, i, min(i+width, n), min(i+2*width, n), B); + } + CopyArray(A, B); + } +} + +int merge_sort(uint64_t *res, const uint64_t *T){ + int i; + + if (SIZE <= 0) + return -1; + + uint64_t B[SIZE]; + uint64_t *A = res; + for (i = 0 ; i < SIZE ; i++) + A[i] = T[i]; + + BottomUpMergeSort(A, B); + + return 0; +} + +#ifdef __UNIT_TEST_MERGE__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (merge_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + uint64_t max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_MERGE__ diff --git a/test/kvx/sort/merge.h b/test/kvx/sort/merge.h new file mode 100644 index 00000000..439ce64a --- /dev/null +++ b/test/kvx/sort/merge.h @@ -0,0 +1,7 @@ +#ifndef __MERGE_H__ +#define __MERGE_H__ + +int merge_sort(uint64_t *res, const uint64_t *T); + +#endif // __MERGE_H__ + diff --git a/test/kvx/sort/selection.c b/test/kvx/sort/selection.c new file mode 100644 index 00000000..df4be04f --- /dev/null +++ b/test/kvx/sort/selection.c @@ -0,0 +1,62 @@ +#include "../prng/prng.h" +#include "../prng/types.h" + +#ifdef __UNIT_TEST_SELECTION__ +#define SIZE 100 +#else +#include "test.h" +#endif + +void swap_sel(uint64_t *a, uint64_t *b){ + uint64_t tmp = *a; + *a = *b; + *b = tmp; +} + +int select_sort(uint64_t *res, const uint64_t *T){ + int i, j, iMin; + + if (SIZE <= 0) + return -1; + + for (i = 0 ; i < SIZE ; i++) + res[i] = T[i]; + + for (j = 0 ; j < SIZE ; j++){ + iMin = j; + for (i = j+1 ; i < SIZE ; i++) + if (res[i] < res[iMin]) + iMin = i; + + if (iMin != j) + swap_sel (&res[j], &res[iMin]); + } + + return 0; +} + +#ifdef __UNIT_TEST_SELECTION__ +int main(void){ + uint64_t T[SIZE]; + uint64_t res[SIZE]; + uint64_t max; + int i; + srand(42); + + for (i = 0 ; i < SIZE ; i++) + T[i] = randlong(); + + /* Sorting the table */ + if (select_sort(res, T) < 0) return -1; + + /* Computing max(T) */ + max = T[0]; + for (i = 1 ; i < SIZE ; i++) + if (T[i] > max) + max = T[i]; + + /* We should have: max(T) == res[SIZE] */ + return !(max == res[SIZE-1]); +} +#endif // __UNIT_TEST_SELECTION__ + diff --git a/test/kvx/sort/selection.h b/test/kvx/sort/selection.h new file mode 100644 index 00000000..92a6b461 --- /dev/null +++ b/test/kvx/sort/selection.h @@ -0,0 +1,6 @@ +#ifndef __SELECTION_H__ +#define __SELECTION_H__ + +int select_sort(uint64_t *res, const uint64_t *T); + +#endif // __SELECTION_H__ diff --git a/test/kvx/sort/test.h b/test/kvx/sort/test.h new file mode 100644 index 00000000..4501ee38 --- /dev/null +++ b/test/kvx/sort/test.h @@ -0,0 +1,6 @@ +#ifndef __TEST_H__ +#define __TEST_H__ + +#define SIZE 100 + +#endif diff --git a/test/mppa/.gitignore b/test/mppa/.gitignore deleted file mode 100644 index b10c40c8..00000000 --- a/test/mppa/.gitignore +++ /dev/null @@ -1,20 +0,0 @@ -check -asm_coverage -instr/Makefile -mmult/Makefile -prng/Makefile -sort/Makefile -prng/.zero -sort/.zero -sort/insertion-ccomp-kvx -sort/insertion-gcc-kvx -sort/insertion-gcc-x86 -sort/main-ccomp-kvx -sort/main-gcc-kvx -sort/main-gcc-x86 -sort/merge-ccomp-kvx -sort/merge-gcc-kvx -sort/merge-gcc-x86 -sort/selection-ccomp-kvx -sort/selection-gcc-kvx -sort/selection-gcc-x86 diff --git a/test/mppa/builtins/clzll.c b/test/mppa/builtins/clzll.c deleted file mode 100644 index 13905cba..00000000 --- a/test/mppa/builtins/clzll.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = __builtin_clzll(a); -} -END_TEST() diff --git a/test/mppa/builtins/stsud.c b/test/mppa/builtins/stsud.c deleted file mode 100644 index fa42b001..00000000 --- a/test/mppa/builtins/stsud.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 2) -{ - c = __builtin_kvx_stsud(t[0], t[1]); -} -END_TEST() diff --git a/test/mppa/coverage.sh b/test/mppa/coverage.sh deleted file mode 100755 index 96f6bc04..00000000 --- a/test/mppa/coverage.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -printer=../../kvx/TargetPrinter.ml -asmdir=instr/asm/ -to_cover_raw=/tmp/to_cover_raw -to_cover=/tmp/to_cover -covered_raw=/tmp/covered_raw -covered=/tmp/covered - -# Stop at any error -set -e -# Pipes do not mask errors -set -o pipefail - -sed -n "s/^.*fprintf\s\+oc\s*\"\s*\([a-z][^[:space:]]*\)\s.*/\1/p" $printer > $to_cover_raw -python2.7 coverage_helper.py $to_cover_raw | sort -u > $to_cover - -rm -f $covered_raw -for asm in $(ls $asmdir/*.ccomp.s); do - grep -v ":" $asm | sed -n "s/^\s*\([a-z][a-z0-9.]*\).*/\1/p" | sort -u >> $covered_raw -done -python2.7 coverage_helper.py $covered_raw | sort -u > $covered - -vimdiff $to_cover $covered diff --git a/test/mppa/coverage_helper.py b/test/mppa/coverage_helper.py deleted file mode 100644 index e5b1907c..00000000 --- a/test/mppa/coverage_helper.py +++ /dev/null @@ -1,45 +0,0 @@ -import fileinput -import sys - -all_loads_stores = "lbs lbz lhz lo lq ld lhs lws sb sd sh so sq sw".split(" ") - -all_bconds = "wnez weqz wltz wgez wlez wgtz dnez deqz dltz dgez dlez dgtz".split(" ") - -all_iconds = "ne eq lt ge le gt ltu geu leu gtu".split(" ") - -all_fconds = "one ueq oeq une olt uge oge ult".split(" ") - -replaces_a = [(["cb.", "cmoved."], all_bconds), - (["compd.", "compw."], all_iconds), - (["fcompd.", "fcompw."], all_fconds), - (all_loads_stores, [".xs", ""])] - -replaces_dd = [(["addx", "sbfx"], ["2d", "4d", "8d", "16d"])] -replaces_dw = [(["addx", "sbfx"], ["2w", "4w", "8w", "16w"])] - -macros_binds = {"%a": replaces_a, "%dd": replaces_dd, "%dw": replaces_dw} - -def expand_macro(fullinst, macro, replaceTable): - inst = fullinst.replace(macro, "") - for (searchlist, mods) in replaceTable: - if inst in searchlist: - return [fullinst.replace(macro, mod) for mod in mods] - raise NameError - -insts = [] -for line in fileinput.input(): - fullinst = line[:-1] - try: - for macro in macros_binds: - if macro in fullinst: - insts.extend(expand_macro(fullinst, macro, macros_binds[macro])) - break - else: - insts.append(fullinst) - except NameError: - print >> sys.stderr, fullinst + " could not be found any match for macro " + macro - sys.exit(1) - -for inst in insts: - print inst -occurs = {} diff --git a/test/mppa/delout.sh b/test/mppa/delout.sh deleted file mode 100755 index e9c72e1c..00000000 --- a/test/mppa/delout.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash - -for folder in prng mmult sort instr interop; do - rm -f $folder/*.out - rm -f $folder/out/* -done diff --git a/test/mppa/do_test.sh b/test/mppa/do_test.sh deleted file mode 100644 index 5cc23dee..00000000 --- a/test/mppa/do_test.sh +++ /dev/null @@ -1,50 +0,0 @@ -do_test () { -cat << EOF - -## -# PRNG tests -## -EOF -(cd prng && make $1 -j$2) - -cat << EOF - -## -# Matrix Multiplication tests -## -EOF -(cd mmult && make $1 -j$2) - -cat << EOF - -## -# List sort tests -## -EOF -(cd sort && make $1 -j$2) - -cat << EOF - -## -# Instruction unit tests -## -EOF -(cd instr && make $1 -j$2) - -cat << EOF - -## -# Interoperability with GCC -## -EOF -(cd interop && make $1 -j$2) - -cat << EOF - -## -# printf wrapper test -## -(cd lib && make $1 -j$2) -EOF - -} diff --git a/test/mppa/general/clzd.c b/test/mppa/general/clzd.c deleted file mode 100644 index d3e8a8ec..00000000 --- a/test/mppa/general/clzd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 1) -{ - c = __builtin_kvx_clzd(t[0]); -} -END_TEST() diff --git a/test/mppa/general/clzw.c b/test/mppa/general/clzw.c deleted file mode 100644 index 7b5478fd..00000000 --- a/test/mppa/general/clzw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 1) -{ - c = __builtin_kvx_clzw(t[0]); -} -END_TEST() diff --git a/test/mppa/general/ctzd.c b/test/mppa/general/ctzd.c deleted file mode 100644 index bba869e1..00000000 --- a/test/mppa/general/ctzd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 1) -{ - c = __builtin_kvx_ctzd(t[0]); -} -END_TEST() diff --git a/test/mppa/general/ctzw.c b/test/mppa/general/ctzw.c deleted file mode 100644 index a7128b04..00000000 --- a/test/mppa/general/ctzw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 1) -{ - c = __builtin_kvx_ctzw(t[0]); -} -END_TEST() diff --git a/test/mppa/general/satd.c b/test/mppa/general/satd.c deleted file mode 100644 index 9d0d1cf9..00000000 --- a/test/mppa/general/satd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 2) -{ - c = __builtin_kvx_satd(t[0], t[1]); -} -END_TEST() diff --git a/test/mppa/general/sbmm8.c b/test/mppa/general/sbmm8.c deleted file mode 100644 index 91f13425..00000000 --- a/test/mppa/general/sbmm8.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 2) -{ - c = __builtin_kvx_sbmm8(t[0], t[1]); -} -END_TEST() diff --git a/test/mppa/general/sbmmt8.c b/test/mppa/general/sbmmt8.c deleted file mode 100644 index 7b120dfa..00000000 --- a/test/mppa/general/sbmmt8.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST_N(unsigned long long, 2) -{ - c = __builtin_kvx_sbmmt8(t[0], t[1]); -} -END_TEST() diff --git a/test/mppa/hardcheck.sh b/test/mppa/hardcheck.sh deleted file mode 100755 index b6538f0e..00000000 --- a/test/mppa/hardcheck.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash -# Tests the execution of the binaries produced by CompCert, in hardware - -source do_test.sh - -do_test hardcheck 1 diff --git a/test/mppa/hardtest.sh b/test/mppa/hardtest.sh deleted file mode 100755 index 6321bc7d..00000000 --- a/test/mppa/hardtest.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/bash -# Tests the validity of the tests, in hardware - -source do_test.sh - -do_test hardtest 1 diff --git a/test/mppa/instr/.gitignore b/test/mppa/instr/.gitignore deleted file mode 100644 index ea1472ec..00000000 --- a/test/mppa/instr/.gitignore +++ /dev/null @@ -1 +0,0 @@ -output/ diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile deleted file mode 100644 index e4f964b3..00000000 --- a/test/mppa/instr/Makefile +++ /dev/null @@ -1,176 +0,0 @@ -SHELL := /bin/bash - -KVXC ?= k1-cos-gcc -CC ?= gcc -CCOMP ?= ccomp -OPTIM ?= -O2 -CFLAGS ?= $(OPTIM) -CCOMPFLAGS ?= $(CFLAGS) -SIMU ?= k1-mppa -TIMEOUT ?= --signal=SIGTERM 120s -DIFF ?= python2.7 floatcmp.py -reltol .00001 -HARDRUN ?= k1-jtag-runner - -DIR=./ -SRCDIR=$(DIR) -OUTDIR=$(DIR)/out -BINDIR=$(DIR)/bin -ASMDIR=$(DIR)/asm -LIB=../lib/system.x86-gcc.a -K1LIB=../lib/system.gcc.a - -## -# Intended flow : .c -> .gcc.s -> .gcc.bin -> .gcc.out -# -> .ccomp.s -> .ccomp.bin -> .ccomp.out -## - -KVXCPATH=$(shell which $(KVXC)) -CCPATH=$(shell which $(CC)) -CCOMPPATH=$(shell which $(CCOMP)) -SIMUPATH=$(shell which $(SIMU)) - -TESTNAMES?=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))) -X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) -GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES))) -CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES))) -GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES))) -CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES))) - -BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES))) - -## -# Targets -## - -all: $(BIN) - -GREEN=\033[0;32m -RED=\033[0;31m -YELLOW=\033[0;33m -NC=\033[0m - -.PHONY: -test: simutest - -.PHONY: -check: simucheck - -.PHONY: -simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) - @echo "Comparing x86 gcc output to k1 gcc.." - for test in $(TESTNAMES); do\ - x86out=$(OUTDIR)/$$test.x86-gcc.out;\ - gccout=$(OUTDIR)/$$test.gcc.simu.out;\ - if grep "__KVX__" -q $$test.c; then\ - printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ - elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ - >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) - @echo "Comparing k1 gcc output to ccomp.." - @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.simu.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\ - if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ - >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) - @echo "Comparing x86 gcc output to k1 gcc.." - for test in $(TESTNAMES); do\ - x86out=$(OUTDIR)/$$test.x86-gcc.out;\ - gccout=$(OUTDIR)/$$test.gcc.hard.out;\ - if grep "__KVX__" -q $$test.c; then\ - printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __KVX__\`\n";\ - elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ - >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT) - @echo "Comparing k1 gcc output to ccomp.." - @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.hard.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\ - if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\ - >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ - fi;\ - done - -## -# Rules -## - -.SECONDARY: -$(LIB): - (cd $(dir $(LIB)) && make) - -$(K1LIB): - (cd $(dir $(LIB)) && make) - -# Generating output - -## Version avec timeout -$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -# Assembly to binary - -$(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(LIB) $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -$(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1LIB) $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ - -$(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(K1LIB) $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CCOMPFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ - -# Source to assembly - -$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CCOMPFLAGS) -S $< -o $@ diff --git a/test/mppa/instr/builtin32.c b/test/mppa/instr/builtin32.c deleted file mode 100644 index 9efb33cd..00000000 --- a/test/mppa/instr/builtin32.c +++ /dev/null @@ -1,12 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) - int *ptr = &c; -#ifdef __KVX__ - int d = c; - a = __builtin_kvx_alclrw(ptr); - c = d; - -#endif -END_TEST32() - diff --git a/test/mppa/instr/builtin64.c b/test/mppa/instr/builtin64.c deleted file mode 100644 index 252eb2c6..00000000 --- a/test/mppa/instr/builtin64.c +++ /dev/null @@ -1,17 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) - long long *ptr = &c; -#ifdef __KVX__ - long long d = c; - a = __builtin_kvx_alclrd(ptr); - c = d; - c += a; - - c += __builtin_clzll(a); - - /* Removed the AFADDD builtin who was incorrect in CompCert, see #157 */ - // a = __builtin_kvx_afaddd(ptr, a); - // a = __builtin_kvx_afaddd(ptr, a); -#endif -END_TEST64() diff --git a/test/mppa/instr/div32.c b/test/mppa/instr/div32.c deleted file mode 100644 index 83c3a0e3..00000000 --- a/test/mppa/instr/div32.c +++ /dev/null @@ -1,5 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) - c = a/b; -END_TEST32() diff --git a/test/mppa/instr/divf32.c b/test/mppa/instr/divf32.c deleted file mode 100644 index 513a3293..00000000 --- a/test/mppa/instr/divf32.c +++ /dev/null @@ -1,5 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(float) - c = a / b; -END_TESTF32() diff --git a/test/mppa/instr/divf64.c b/test/mppa/instr/divf64.c deleted file mode 100644 index 0dd23826..00000000 --- a/test/mppa/instr/divf64.c +++ /dev/null @@ -1,5 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(double) - c = a / b; -END_TESTF64() diff --git a/test/mppa/instr/divu32.c b/test/mppa/instr/divu32.c deleted file mode 100644 index 1fe196c4..00000000 --- a/test/mppa/instr/divu32.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = a/b; -} -END_TEST32() diff --git a/test/mppa/instr/f32.c b/test/mppa/instr/f32.c deleted file mode 100644 index 7e304aeb..00000000 --- a/test/mppa/instr/f32.c +++ /dev/null @@ -1,8 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(float) - c = ((float)a + (float)b); - c += ((float)a * (float)b); - c += (-(float)a); - c += ((float)a - (float)b); -END_TESTF32() diff --git a/test/mppa/instr/f64.c b/test/mppa/instr/f64.c deleted file mode 100644 index be8094c9..00000000 --- a/test/mppa/instr/f64.c +++ /dev/null @@ -1,8 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(double) - c = ((double)a + (double)b); - c += ((double)a * (double)b); - c += (-(double)a); - c += ((double)a - (double)b); -END_TESTF64() diff --git a/test/mppa/instr/floatcmp.py b/test/mppa/instr/floatcmp.py deleted file mode 100755 index 49f1bc13..00000000 --- a/test/mppa/instr/floatcmp.py +++ /dev/null @@ -1,93 +0,0 @@ -#!/usr/bin/python2.7 - -import argparse as ap -import sys - -parser = ap.ArgumentParser() -parser.add_argument("file1", help="First file to compare") -parser.add_argument("file2", help="Second file to compare") -parser.add_argument("-reltol", help="Relative error") -parser.add_argument("-abstol", help="Absolute error") -parser.add_argument("-s", help="Silent output", action="store_true") -args = parser.parse_args() - -reltol = float(args.reltol) if args.reltol else None -abstol = float(args.abstol) if args.abstol else None -silent = args.s - -if silent: - sys.stdout = open("/dev/null", "w") - -import re -from math import fabs - -def floatcmp(f1, f2): - if abstol: - if fabs(f1 - f2) > abstol: - return False - if reltol: - if f2 != 0. and fabs((f1 - f2) / f2) > reltol: - return False - return True - -class Parsed(list): - def __eq__(self, other): - if len(self) != len(other): - return False - comps = zip(self, other) - for comp in comps: - if all(isinstance(compElt, str) for compElt in comp): - if comp[0] != comp[1]: - return False - elif all (isinstance(compElt, float) for compElt in comp): - if not floatcmp(comp[0], comp[1]): - return False - else: - return False - return True - - def __ne__(self, other): - return not self.__eq__(other) - -parseLine = re.compile(r"\s*(\S+)") -def readline(line): - words = parseLine.findall(line) - parsed = Parsed([]) - for word in words: - try: - parse = float(word) - parsed.append(parse) - except ValueError: - parsed.append(word) - return parsed - -def readfile(filename): - L = [] - try: - with open(filename) as f: - for line in f: - L.append(readline(line)) - except IOError: - print "Unable to read {}".format(filename) - sys.exit(2) - return L - -L1 = readfile(args.file1) -L2 = readfile(args.file2) - -if len(L1) != len(L2): - print "The files have different amount of lines" - print "\t{}: {} lines".format(args.file1, len(L1)) - print "\t{}: {} lines".format(args.file2, len(L2)) - sys.exit(1) - -cmpL = zip(L1, L2) -for i, cmpElt in enumerate(cmpL): - if cmpElt[0] != cmpElt[1]: - print "The files differ at line {}".format(i) - print "\t{}: {}".format(args.file1, cmpElt[0]) - print "\t{}: {}".format(args.file2, cmpElt[1]) - sys.exit(1) - -print "Comparison succeeded" -sys.exit(0) diff --git a/test/mppa/instr/framework.h b/test/mppa/instr/framework.h deleted file mode 100644 index 3bbfa271..00000000 --- a/test/mppa/instr/framework.h +++ /dev/null @@ -1,66 +0,0 @@ -#ifndef __FRAMEWORK_H__ -#define __FRAMEWORK_H__ - -#include -#include "../prng/prng.c" - -#define BEGIN_TEST_N(type, N)\ - int main(void){\ - type t[N], c, i, j, S;\ - srand(0);\ - S = 0;\ - for (i = 0 ; i < 100 ; i++){\ - c = randlong();\ - for (j = 0 ; j < N ; j++)\ - t[j] = randlong();\ - /* END BEGIN_TEST_N */ - -#define BEGIN_TEST(type)\ - int main(void){\ - type a, b, c, S;\ - int i;\ - srand(0);\ - S = 0;\ - for (i = 0 ; i < 100 ; i++){\ - c = randlong();\ - a = randlong();\ - b = randlong(); - /* END BEGIN_TEST */ - -/* In between BEGIN_TEST and END_TEST : definition of c */ - -#define END_TEST64()\ - printf("%llu\t%llu\t%llu\n", a, b, c);\ - S += c;\ - }\ - return S;\ - } - /* END END_TEST64 */ - -#define END_TEST32()\ - printf("%u\t%u\t%u\n", a, b, c);\ - S += c;\ - }\ - return S;\ - } - /* END END_TEST32 */ - -#define END_TESTF32()\ - printf("%e\t%e\t%e\n", a, b, c);\ - S += c;\ - }\ - return 0;\ - } - /* END END_TESTF32 */ - -#define END_TESTF64()\ - printf("%e\t%e\t%e\n", a, b, c);\ - S += c;\ - }\ - return 0;\ - } - /* END END_TESTF64 */ - -#endif - - diff --git a/test/mppa/instr/i32.c b/test/mppa/instr/i32.c deleted file mode 100644 index e350931c..00000000 --- a/test/mppa/instr/i32.c +++ /dev/null @@ -1,149 +0,0 @@ -#include "framework.h" - -int sum(int a, int b){ - return a+b; -} - -int make(int a){ - return a; -} - -int tailsum(int a, int b){ - return make(a+b); -} - -int fact(int a){ - int r = 1; - int i; - for (i = 1; i < a; i++) - r *= i; - return r; -} - -float int2float(int v){ - return v; -} - -BEGIN_TEST(int) - c = a+b; - c += a&b; - - /* testing if, cb version */ - if ((a & 0x1) == 1) - c += fact(1); - else - c += fact(2); - - if (a & 0x1 == 0) - c += fact(4); - else - c += fact(8); - - if (a & 0x1 == 0) - c += fact(4); - else - c += fact(8); - - b = !(a & 0x01); - if (!b) - c += fact(16); - else - c += fact(32); - - c += sum(make(a), make(b)); - c += (long long) a; - - if (0 > (a & 0x1) - 1) - c += fact(64); - else - c += fact(128); - - if (0 >= (a & 0x1)) - c += fact(256); - else - c += fact(512); - - if ((a & 0x1) > 0) - c += fact(1024); - else - c += fact(2048); - - if ((a & 0x1) - 1 >= 0) - c += fact(4096); - else - c += fact(8192); - - /* cmoved version */ - if ((a & 0x1) == 1) - c += 1; - else - c += 2; - - if (a & 0x1 == 0) - c += 4; - else - c += 8; - - if (a & 0x1 == 0) - c += 4; - else - c += 8; - - b = !(a & 0x01); - if (!b) - c += 16; - else - c += 32; - - if (0 > (a & 0x1) - 1) - c += 64; - else - c += 128; - - if (0 >= (a & 0x1)) - c += 256; - else - c += 512; - - if ((a & 0x1) > 0) - c += 1024; - else - c += 2048; - - if ((a & 0x1) - 1 >= 0) - c += 4096; - else - c += 8192; - - c += ((a & 0x1) == (b & 0x1)); - c += (a > b); - c += (a <= b); - c += (a < b); - c += (a + b) / 2; - c += (int) int2float(a) + (int) int2float(b) + (int) int2float(42.3); - c += (a << 4); // addx16w - c += (a << 3); // addx8w - c += (a << 2); // addx4w - c += (a << 1); // addx2w - - c += ~a & b; // andnw - - int j; - for (j = 0 ; j < 10 ; j++) - c += a; - int k; - for (k = 0 ; k < (b & 0x8) ; k++) - c += a; - - char s[] = "Tome and Cherry at the playa\n"; - c += s[(a & (sizeof(s)-1))]; - - unsigned char s2[] = "Tim is sorry at the playa\n"; - c += s2[a & (sizeof(s) - 1)]; - - c += a*b; - c += a-b; - c += a << (b & 0x8); - - c += sum(a, b); -END_TEST32() diff --git a/test/mppa/instr/i64.c b/test/mppa/instr/i64.c deleted file mode 100644 index e869d93c..00000000 --- a/test/mppa/instr/i64.c +++ /dev/null @@ -1,169 +0,0 @@ -#include "framework.h" - -long long sum(long long a, long long b){ - return a+b; -} - -long long diff(long long a, long long b){ - return a-b; -} - -long long mul(long long a, long long b){ - return a*b; -} - -long long make(long long a){ - return a; -} - -long long random_op(long long a, long long b){ - long long d = 3; - long long (*op)(long long, long long); - - if (a % d == 0) - op = sum; - else if (a % d == 1) - op = diff; - else - op = mul; - - return op(a, b); -} - -long fact(long a){ - long r = 1; - long i; - for (i = 1; i < a; i++) - r *= i; - return r; -} - -double long2double(long v){ - return v; -} - -BEGIN_TEST(long long) - c = a&b; - c += a*b; - c += -a; - c += a | b; - c += a-b; - c += a >> (b & 0x8LL); - c += a >> (b & 0x8ULL); - c += a % b; - c += (a << 4); // addx16d - c += (a << 3); // addx8d - c += (a << 2); // addx4d - c += (a << 1); // addx2d - - c += ~a & b; // andnd - - long long d = 3; - long long (*op)(long long, long long); - - if (a % d == 0) - op = sum; - else if (a % d == 1) - op = diff; - else - op = mul; - - c += op(make(a), make(b)); - c += random_op(a, b); - c += a/b; - c += a^b; - c += (unsigned int) a; - - /* Testing if, cb */ - if (0 != (a & 0x1LL)) - c += fact(1); - else - c += fact(2); - - if (0 > (a & 0x1LL)) - c += fact(4); - else - c += fact(8); - - if (0 >= (a & 0x1LL) - 1) - c += fact(16); - else - c += fact(32); - - if ((unsigned long long)(a & 0x1LL) >= 1) - c += fact(18); - else - c += fact(31); - - - if (a-41414141 > 0) - c += fact(13); - else - c += fact(31); - - if (a & 0x1LL > 0) - c += fact(64); - else - c += fact(128); - - if ((a & 0x1LL) - 1 >= 0) - c += fact(256); - else - c += fact(512); - - if (0 == (a & 0x1LL)) - c += fact(1024); - else - c += fact(2048); - - /* Testing if, cmoved */ - if (0 != (a & 0x1LL)) - c += 1; - else - c += 2; - - if (0 > (a & 0x1LL)) - c += 4; - else - c += 8; - - if (0 >= (a & 0x1LL) - 1) - c += 16; - else - c += 32; - - if (a-41414141 > 0) - c += 13; - else - c += 31; - - if (a & 0x1LL > 0) - c += 64; - else - c += 128; - - if ((a & 0x1LL) - 1 >= 0) - c += 256; - else - c += 512; - - if (0 == (a & 0x1LL)) - c += 1024; - else - c += 2048; - - c += ((a & 0x1LL) == (b & 0x1LL)); - c += (a >= b); - c += (a > b); - c += (a <= b); - c += (a < b); - c += (long) long2double(a) + (long) long2double(b) + (long) long2double(42.3); - - int j; - - for (j = 0 ; j < (b & 0x8LL) ; j++) - c += a; - - c += ((a & 0x1LL) == (b & 0x1LL)); - -END_TEST64() diff --git a/test/mppa/instr/individual/andw.c b/test/mppa/instr/individual/andw.c deleted file mode 100644 index 799dc7fb..00000000 --- a/test/mppa/instr/individual/andw.c +++ /dev/null @@ -1,5 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) - c = a&b; -END_TEST32() diff --git a/test/mppa/instr/individual/branch.c b/test/mppa/instr/individual/branch.c deleted file mode 100644 index c9937e31..00000000 --- a/test/mppa/instr/individual/branch.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if ((a & 0x1) == 1) - c = 0; - else - c = 1; -} -END_TEST32() diff --git a/test/mppa/instr/individual/branchz.c b/test/mppa/instr/individual/branchz.c deleted file mode 100644 index d3e021b5..00000000 --- a/test/mppa/instr/individual/branchz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if (a & 0x1 == 0) - c = 0; - else - c = 1; -} -END_TEST32() diff --git a/test/mppa/instr/individual/branchzu.c b/test/mppa/instr/individual/branchzu.c deleted file mode 100644 index d0169174..00000000 --- a/test/mppa/instr/individual/branchzu.c +++ /dev/null @@ -1,11 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - b = !(a & 0x01); - if (!b) - c = 0; - else - c = 1; -} -END_TEST32() diff --git a/test/mppa/instr/individual/call.c b/test/mppa/instr/individual/call.c deleted file mode 100644 index ba2ec323..00000000 --- a/test/mppa/instr/individual/call.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "framework.h" - -int sum(int a, int b){ - return a+b; -} - -int make(int a){ - return a; -} - -BEGIN_TEST(int) -{ - c = sum(make(a), make(b)); -} -END_TEST32() -/* RETURN VALUE: 60 */ diff --git a/test/mppa/instr/individual/cast_S32_S64.c b/test/mppa/instr/individual/cast_S32_S64.c deleted file mode 100644 index 09c97e00..00000000 --- a/test/mppa/instr/individual/cast_S32_S64.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = (long long) a; -} -END_TEST32() diff --git a/test/mppa/instr/individual/cast_S64_U32.c b/test/mppa/instr/individual/cast_S64_U32.c deleted file mode 100644 index 2d9dc723..00000000 --- a/test/mppa/instr/individual/cast_S64_U32.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = (unsigned int) a; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.deqz.c b/test/mppa/instr/individual/cb.deqz.c deleted file mode 100644 index 6da2ab07..00000000 --- a/test/mppa/instr/individual/cb.deqz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if (0 != (a & 0x1LL)) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.dgez.c b/test/mppa/instr/individual/cb.dgez.c deleted file mode 100644 index 7bef25ad..00000000 --- a/test/mppa/instr/individual/cb.dgez.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if (0 > (a & 0x1LL)) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.dgtz.c b/test/mppa/instr/individual/cb.dgtz.c deleted file mode 100644 index 1a43fb1f..00000000 --- a/test/mppa/instr/individual/cb.dgtz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if (0 >= (a & 0x1LL) - 1) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.dlez.c b/test/mppa/instr/individual/cb.dlez.c deleted file mode 100644 index 2fb97939..00000000 --- a/test/mppa/instr/individual/cb.dlez.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if (a & 0x1LL > 0) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.dltz.c b/test/mppa/instr/individual/cb.dltz.c deleted file mode 100644 index a431d5d0..00000000 --- a/test/mppa/instr/individual/cb.dltz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if ((a & 0x1LL) - 1 >= 0) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.dnez.c b/test/mppa/instr/individual/cb.dnez.c deleted file mode 100644 index 44516cbe..00000000 --- a/test/mppa/instr/individual/cb.dnez.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - if (0 == (a & 0x1LL)) - c = 1; - else - c = 0; -} -END_TEST64() diff --git a/test/mppa/instr/individual/cb.wgez.c b/test/mppa/instr/individual/cb.wgez.c deleted file mode 100644 index 5779ad92..00000000 --- a/test/mppa/instr/individual/cb.wgez.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if (0 > (a & 0x1) - 1) - c = 1; - else - c = 0; -} -END_TEST32() diff --git a/test/mppa/instr/individual/cb.wgtz.c b/test/mppa/instr/individual/cb.wgtz.c deleted file mode 100644 index abb695bd..00000000 --- a/test/mppa/instr/individual/cb.wgtz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if (0 >= (a & 0x1)) - c = 1; - else - c = 0; -} -END_TEST32() diff --git a/test/mppa/instr/individual/cb.wlez.c b/test/mppa/instr/individual/cb.wlez.c deleted file mode 100644 index 3a2e08c1..00000000 --- a/test/mppa/instr/individual/cb.wlez.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if ((a & 0x1) > 0) - c = 1; - else - c = 0; -} -END_TEST32() diff --git a/test/mppa/instr/individual/cb.wltz.c b/test/mppa/instr/individual/cb.wltz.c deleted file mode 100644 index 5d52c72a..00000000 --- a/test/mppa/instr/individual/cb.wltz.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - if ((a & 0x1) - 1 >= 0) - c = 1; - else - c = 0; -} -END_TEST32() diff --git a/test/mppa/instr/individual/compd.eq.c b/test/mppa/instr/individual/compd.eq.c deleted file mode 100644 index 4fe8de2a..00000000 --- a/test/mppa/instr/individual/compd.eq.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = ((a & 0x1LL) == (b & 0x1LL)); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.geu.c b/test/mppa/instr/individual/compd.geu.c deleted file mode 100644 index fccf0804..00000000 --- a/test/mppa/instr/individual/compd.geu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = (a >= b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.gt.c b/test/mppa/instr/individual/compd.gt.c deleted file mode 100644 index b9901436..00000000 --- a/test/mppa/instr/individual/compd.gt.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = (a > b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.le.c b/test/mppa/instr/individual/compd.le.c deleted file mode 100644 index 6fa0f103..00000000 --- a/test/mppa/instr/individual/compd.le.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = (a <= b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.leu.c b/test/mppa/instr/individual/compd.leu.c deleted file mode 100644 index 1ad18281..00000000 --- a/test/mppa/instr/individual/compd.leu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = (a <= b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.lt.c b/test/mppa/instr/individual/compd.lt.c deleted file mode 100644 index c42cda56..00000000 --- a/test/mppa/instr/individual/compd.lt.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = (a < b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.ltu.c b/test/mppa/instr/individual/compd.ltu.c deleted file mode 100644 index b03d4d53..00000000 --- a/test/mppa/instr/individual/compd.ltu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = (a < b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compd.ne.c b/test/mppa/instr/individual/compd.ne.c deleted file mode 100644 index fd9d0b28..00000000 --- a/test/mppa/instr/individual/compd.ne.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = ((a & 0x1ULL) != (b & 0x1ULL)); -} -END_TEST64() diff --git a/test/mppa/instr/individual/compw.eq.c b/test/mppa/instr/individual/compw.eq.c deleted file mode 100644 index cd93f365..00000000 --- a/test/mppa/instr/individual/compw.eq.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = ((a & 0x1) == (b & 0x1)); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.geu.c b/test/mppa/instr/individual/compw.geu.c deleted file mode 100644 index b8fb1adf..00000000 --- a/test/mppa/instr/individual/compw.geu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = (a >= b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.gt.c b/test/mppa/instr/individual/compw.gt.c deleted file mode 100644 index 5f6bc907..00000000 --- a/test/mppa/instr/individual/compw.gt.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = (a > b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.gtu.c b/test/mppa/instr/individual/compw.gtu.c deleted file mode 100644 index 947f6a14..00000000 --- a/test/mppa/instr/individual/compw.gtu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = (a > b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.le.c b/test/mppa/instr/individual/compw.le.c deleted file mode 100644 index 35ec6b7d..00000000 --- a/test/mppa/instr/individual/compw.le.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = (a <= b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.leu.c b/test/mppa/instr/individual/compw.leu.c deleted file mode 100644 index 74ebfb42..00000000 --- a/test/mppa/instr/individual/compw.leu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = (a <= b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.lt.c b/test/mppa/instr/individual/compw.lt.c deleted file mode 100644 index cb1f30bd..00000000 --- a/test/mppa/instr/individual/compw.lt.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = (a < b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.ltu.c b/test/mppa/instr/individual/compw.ltu.c deleted file mode 100644 index 6a0c5af1..00000000 --- a/test/mppa/instr/individual/compw.ltu.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = (a < b); -} -END_TEST32() diff --git a/test/mppa/instr/individual/compw.ne.c b/test/mppa/instr/individual/compw.ne.c deleted file mode 100644 index 7035e2c7..00000000 --- a/test/mppa/instr/individual/compw.ne.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = ((a & 0x1U) != (b & 0x1U)); -} -END_TEST32() diff --git a/test/mppa/instr/individual/div2.c b/test/mppa/instr/individual/div2.c deleted file mode 100644 index b5dfe63a..00000000 --- a/test/mppa/instr/individual/div2.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = (a + b) / 2; -} -END_TEST32() diff --git a/test/mppa/instr/individual/doubleconv.c b/test/mppa/instr/individual/doubleconv.c deleted file mode 100644 index 55b1ddab..00000000 --- a/test/mppa/instr/individual/doubleconv.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -double long2double(long v){ - return v; -} - -BEGIN_TEST(long) - c = (long) long2double(a) + (long) long2double(b) + (long) long2double(42.3); -END_TEST64() diff --git a/test/mppa/instr/individual/floatconv.c b/test/mppa/instr/individual/floatconv.c deleted file mode 100644 index 32b798e1..00000000 --- a/test/mppa/instr/individual/floatconv.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -float int2float(int v){ - return v; -} - -BEGIN_TEST(int) - c = (int) int2float(a) + (int) int2float(b) + (int) int2float(42.3); -END_TEST32() diff --git a/test/mppa/instr/individual/fmuld.c b/test/mppa/instr/individual/fmuld.c deleted file mode 100644 index 03c990fa..00000000 --- a/test/mppa/instr/individual/fmuld.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(double) -{ - c = ((double)a * (double)b); -} -END_TESTF64() diff --git a/test/mppa/instr/individual/fmulw.c b/test/mppa/instr/individual/fmulw.c deleted file mode 100644 index f85eba64..00000000 --- a/test/mppa/instr/individual/fmulw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(float) -{ - c = ((float)a * (float)b); -} -END_TESTF32() diff --git a/test/mppa/instr/individual/fnegd.c b/test/mppa/instr/individual/fnegd.c deleted file mode 100644 index 974eb7e8..00000000 --- a/test/mppa/instr/individual/fnegd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(double) -{ - c = (-(double)a); -} -END_TESTF64() diff --git a/test/mppa/instr/individual/fnegw.c b/test/mppa/instr/individual/fnegw.c deleted file mode 100644 index fbeaab8e..00000000 --- a/test/mppa/instr/individual/fnegw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(float) -{ - c = (-(float)a); -} -END_TESTF64() diff --git a/test/mppa/instr/individual/for.c b/test/mppa/instr/individual/for.c deleted file mode 100644 index 373ab6bd..00000000 --- a/test/mppa/instr/individual/for.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - int j; - for (j = 0 ; j < 10 ; j++) - c += a; -} -END_TEST32() diff --git a/test/mppa/instr/individual/forvar.c b/test/mppa/instr/individual/forvar.c deleted file mode 100644 index 9e43c198..00000000 --- a/test/mppa/instr/individual/forvar.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - int k; - for (k = 0 ; k < (b & 0x8) ; k++) - c += a; -} -END_TEST32() diff --git a/test/mppa/instr/individual/forvarl.c b/test/mppa/instr/individual/forvarl.c deleted file mode 100644 index c1fe90fd..00000000 --- a/test/mppa/instr/individual/forvarl.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long int) -{ - int j; - - for (j = 0 ; j < (b & 0x8LL) ; j++) - c += a; -} -END_TEST64() diff --git a/test/mppa/instr/individual/fsbfd.c b/test/mppa/instr/individual/fsbfd.c deleted file mode 100644 index f80c1efe..00000000 --- a/test/mppa/instr/individual/fsbfd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(double) -{ - c = ((double)a - (double)b); -} -END_TESTF64() diff --git a/test/mppa/instr/individual/fsbfw.c b/test/mppa/instr/individual/fsbfw.c deleted file mode 100644 index 067c40b5..00000000 --- a/test/mppa/instr/individual/fsbfw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(float) -{ - c = ((float)a - (float)b); -} -END_TESTF64() diff --git a/test/mppa/instr/individual/indirect_call.c b/test/mppa/instr/individual/indirect_call.c deleted file mode 100644 index f376c00a..00000000 --- a/test/mppa/instr/individual/indirect_call.c +++ /dev/null @@ -1,33 +0,0 @@ -#include "framework.h" - -long long sum(long long a, long long b){ - return a+b; -} - -long long diff(long long a, long long b){ - return a-b; -} - -long long mul(long long a, long long b){ - return a*b; -} - -long long make(long long a){ - return a; -} - -BEGIN_TEST(long long) -{ - long long d = 3; - long long (*op)(long long, long long); - - if (a % d == 0) - op = sum; - else if (a % d == 1) - op = diff; - else - op = mul; - - c += op(make(a), make(b)); -} -END_TEST64() diff --git a/test/mppa/instr/individual/indirect_tailcall.c b/test/mppa/instr/individual/indirect_tailcall.c deleted file mode 100644 index e6c16ea1..00000000 --- a/test/mppa/instr/individual/indirect_tailcall.c +++ /dev/null @@ -1,33 +0,0 @@ -#include "framework.h" - -long long sum(long long a, long long b){ - return a+b; -} - -long long diff(long long a, long long b){ - return a-b; -} - -long long mul(long long a, long long b){ - return a*b; -} - -long long random_op(long long a, long long b){ - long long d = 3; - long long (*op)(long long, long long); - - if (a % d == 0) - op = sum; - else if (a % d == 1) - op = diff; - else - op = mul; - - return op(a, b); -} - -BEGIN_TEST(long long) -{ - c += random_op(a, b); -} -END_TEST64() diff --git a/test/mppa/instr/individual/lbs.c b/test/mppa/instr/individual/lbs.c deleted file mode 100644 index 22a50632..00000000 --- a/test/mppa/instr/individual/lbs.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - char s[] = "Tome and Cherry at the playa\n"; - - c = s[(a & (sizeof(s)-1))]; -} -END_TEST32() diff --git a/test/mppa/instr/individual/lbz.c b/test/mppa/instr/individual/lbz.c deleted file mode 100644 index 04ba098d..00000000 --- a/test/mppa/instr/individual/lbz.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - unsigned char s[] = "Tim is sorry at the playa\n"; - - c = s[a & (sizeof(s) - 1)]; -} -END_TEST32() diff --git a/test/mppa/instr/individual/muld.c b/test/mppa/instr/individual/muld.c deleted file mode 100644 index f7e23850..00000000 --- a/test/mppa/instr/individual/muld.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = a*b; -} -END_TEST64() diff --git a/test/mppa/instr/individual/mulw.c b/test/mppa/instr/individual/mulw.c deleted file mode 100644 index a91d966e..00000000 --- a/test/mppa/instr/individual/mulw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = a * b; -} -END_TEST32() diff --git a/test/mppa/instr/individual/negd.c b/test/mppa/instr/individual/negd.c deleted file mode 100644 index 837b9828..00000000 --- a/test/mppa/instr/individual/negd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = -a; -} -END_TEST64() diff --git a/test/mppa/instr/individual/ord.c b/test/mppa/instr/individual/ord.c deleted file mode 100644 index cae1ae8b..00000000 --- a/test/mppa/instr/individual/ord.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = a | b; -} -END_TEST64() diff --git a/test/mppa/instr/individual/sbfd.c b/test/mppa/instr/individual/sbfd.c deleted file mode 100644 index 77c28c77..00000000 --- a/test/mppa/instr/individual/sbfd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = a-b; -} -END_TEST64() diff --git a/test/mppa/instr/individual/sbfw.c b/test/mppa/instr/individual/sbfw.c deleted file mode 100644 index e38a1fff..00000000 --- a/test/mppa/instr/individual/sbfw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = a-b; -} -END_TEST32() diff --git a/test/mppa/instr/individual/simple.c b/test/mppa/instr/individual/simple.c deleted file mode 100644 index 944f09c9..00000000 --- a/test/mppa/instr/individual/simple.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = a+b; -} -END_TEST32() diff --git a/test/mppa/instr/individual/sllw.c b/test/mppa/instr/individual/sllw.c deleted file mode 100644 index 6dd41a6c..00000000 --- a/test/mppa/instr/individual/sllw.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) -{ - c = a << (b & 0x8); -} -END_TEST32() diff --git a/test/mppa/instr/individual/srad.c b/test/mppa/instr/individual/srad.c deleted file mode 100644 index 00be9d0c..00000000 --- a/test/mppa/instr/individual/srad.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = a >> (b & 0x8LL); -} -END_TEST64() diff --git a/test/mppa/instr/individual/srld.c b/test/mppa/instr/individual/srld.c deleted file mode 100644 index 14970efd..00000000 --- a/test/mppa/instr/individual/srld.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = a >> (b & 0x8ULL); -} -END_TEST64() diff --git a/test/mppa/instr/individual/tailcall.c b/test/mppa/instr/individual/tailcall.c deleted file mode 100644 index 6c659a01..00000000 --- a/test/mppa/instr/individual/tailcall.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "framework.h" - -int make(int a){ - return a; -} - -int sum(int a, int b){ - return make(a+b); -} - -BEGIN_TEST(int) -{ - c = sum(a, b); -} -END_TEST32() -/* RETURN VALUE: 60 */ diff --git a/test/mppa/instr/individual/udivd.c b/test/mppa/instr/individual/udivd.c deleted file mode 100644 index cfb31881..00000000 --- a/test/mppa/instr/individual/udivd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = a/b; -} -END_TEST64() diff --git a/test/mppa/instr/individual/umodd.c b/test/mppa/instr/individual/umodd.c deleted file mode 100644 index a7f25f1c..00000000 --- a/test/mppa/instr/individual/umodd.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = a%b; -} -END_TEST64() diff --git a/test/mppa/instr/individual/xord.c b/test/mppa/instr/individual/xord.c deleted file mode 100644 index b6a90cb0..00000000 --- a/test/mppa/instr/individual/xord.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(long long) -{ - c = a^b; -} -END_TEST64() diff --git a/test/mppa/instr/modi32.c b/test/mppa/instr/modi32.c deleted file mode 100644 index 958ae920..00000000 --- a/test/mppa/instr/modi32.c +++ /dev/null @@ -1,5 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(int) - c = a%b; -END_TEST32() diff --git a/test/mppa/instr/modui32.c b/test/mppa/instr/modui32.c deleted file mode 100644 index a39034a8..00000000 --- a/test/mppa/instr/modui32.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = a%b; -} -END_TEST32() diff --git a/test/mppa/instr/ui32.c b/test/mppa/instr/ui32.c deleted file mode 100644 index f56a9b95..00000000 --- a/test/mppa/instr/ui32.c +++ /dev/null @@ -1,12 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned int) -{ - c = (long long) a; - c += (a >= b); - c += (a > b); - c += (a <= b); - c += (a < b); - c += ((a & 0x1U) != (b & 0x1U)); -} -END_TEST32() diff --git a/test/mppa/instr/ui64.c b/test/mppa/instr/ui64.c deleted file mode 100644 index 908dec3c..00000000 --- a/test/mppa/instr/ui64.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "framework.h" - -BEGIN_TEST(unsigned long long) -{ - c = (a > b); - c += (a <= b); - c += (a < b); - c += ((a & 0x1ULL) != (b & 0x1ULL)); -} -END_TEST64() diff --git a/test/mppa/interop/.gitignore b/test/mppa/interop/.gitignore deleted file mode 100644 index ea1472ec..00000000 --- a/test/mppa/interop/.gitignore +++ /dev/null @@ -1 +0,0 @@ -output/ diff --git a/test/mppa/interop/Makefile b/test/mppa/interop/Makefile deleted file mode 100644 index a0d4d7da..00000000 --- a/test/mppa/interop/Makefile +++ /dev/null @@ -1,365 +0,0 @@ -SHELL := /bin/bash - -KVXC ?= k1-cos-gcc -CC ?= gcc -CCOMP ?= ccomp -CFLAGS ?= -O2 -Wno-varargs -SIMU ?= k1-mppa -TIMEOUT ?= --signal=SIGTERM 120s -HARDRUN ?= k1-jtag-runner - -DIR=./ -SRCDIR=$(DIR) -OUTDIR=$(DIR)/out -BINDIR=$(DIR)/bin -ASMDIR=$(DIR)/asm -OBJDIR=$(DIR)/obj -COMMON=common -VAARG_COMMON=vaarg_common - -## -# Intended flow : .c -> .gcc.s -> .gcc.o -> .gcc.bin -> .gcc.out -# -> .ccomp.s -> .ccomp.o -> .ccomp.bin -> .ccomp.out -# -> .x86-gcc.s -> .x86-gcc.o -> .x86-gcc.bin -> .x86-gcc.out -# -# The .o -> .bin part uses $(COMMON).gcc.o or $(COMMON).x86-gcc.o depending on the architecture -# There is also a $(VAARG_COMMON) that is the same than $(COMMON) but with va_arg -## - -KVXCPATH=$(shell which $(KVXC)) -CCPATH=$(shell which $(CC)) -CCOMPPATH=$(shell which $(CCOMP)) -SIMUPATH=$(shell which $(SIMU)) - -TESTNAMES ?= $(filter-out $(VAARG_COMMON),$(filter-out $(COMMON),$(notdir $(subst .c,,$(wildcard $(DIR)/*.c))))) - -X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) -GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES))) -GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.simu.out,$(TESTNAMES))) -CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES))) - -GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES))) -GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.hard.out,$(TESTNAMES))) -CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES))) - -VAARG_X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.vaarg.out,$(TESTNAMES))) -VAARG_GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.simu.out,$(TESTNAMES))) -VAARG_GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.simu.out,$(TESTNAMES))) -VAARG_CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.simu.out,$(TESTNAMES))) - -VAARG_GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.hard.out,$(TESTNAMES))) -VAARG_GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.hard.out,$(TESTNAMES))) -VAARG_CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.hard.out,$(TESTNAMES))) - -BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.rev.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.vaarg.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.vaarg.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .ccomp.vaarg.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.rev.vaarg.bin,$(TESTNAMES))) - -## -# Targets -## - -all: $(BIN) - -GREEN=\033[0;32m -RED=\033[0;31m -NC=\033[0m - -.PHONY: -test: simutest - -.PHONY: -simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_SIMUOUT) - @echo "Comparing x86 gcc output to k1 gcc.." - @for test in $(TESTNAMES); do\ - x86out=$(OUTDIR)/$$test.x86-gcc.out;\ - gccout=$(OUTDIR)/$$test.gcc.simu.out;\ - vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\ - vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\ - if ! diff $$x86out $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_x86out $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_x86out and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_x86out and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -check: simucheck - -.PHONY: -simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) $(GCC_REV_SIMUOUT) $(VAARG_GCC_SIMUOUT) $(VAARG_CCOMP_SIMUOUT) $(VAARG_GCC_REV_SIMUOUT) - @echo "Comparing k1 gcc output to ccomp.." - @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.simu.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\ - gccrevout=$(OUTDIR)/$$test.gcc.rev.simu.out;\ - vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\ - vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.simu.out;\ - vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.simu.out;\ - if ! diff $$ccompout $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$gccrevout $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$gccrevout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$gccrevout and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_ccompout $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_ccompout and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_ccompout and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_gccrevout $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_gccrevout and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_gccrevout and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_HARDOUT) - @echo "Comparing x86 gcc output to k1 gcc.." - @for test in $(TESTNAMES); do\ - x86out=$(OUTDIR)/$$test.x86-gcc.out;\ - gccout=$(OUTDIR)/$$test.gcc.hard.out;\ - vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\ - vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\ - if ! diff $$x86out $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_x86out $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_x86out and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_x86out and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - done - -.PHONY: -hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT) $(GCC_REV_HARDOUT) $(VAARG_GCC_HARDOUT) $(VAARG_CCOMP_HARDOUT) $(VAARG_GCC_REV_HARDOUT) - @echo "Comparing k1 gcc output to ccomp.." - @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.hard.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\ - gccrevout=$(OUTDIR)/$$test.gcc.rev.hard.out;\ - vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\ - vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.hard.out;\ - vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.hard.out;\ - if ! diff $$ccompout $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$gccrevout $$gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$gccrevout and $$gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$gccrevout and $$gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_ccompout $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_ccompout and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_ccompout and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - if ! diff $$vaarg_gccrevout $$vaarg_gccout > /dev/null; then\ - >&2 printf "$(RED)ERROR: $$vaarg_gccrevout and $$vaarg_gccout differ$(NC)\n";\ - else\ - printf "$(GREEN)GOOD: $$vaarg_gccrevout and $$vaarg_gccout concur$(NC)\n";\ - fi;\ - done - -## -# Rules -## - -.SECONDARY: - -## -# Generating output -## - -## Version sans les timeout -#$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin -# @mkdir -p $(@D) -# ./$< > $@; echo $$? >> $@ -# -#$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) -# @mkdir -p $(@D) -# $(SIMU) -- $< > $@ ; echo $$? >> $@ -# -#$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) -# @mkdir -p $(@D) -# $(SIMU) -- $< > $@ ; echo $$? >> $@ - -## No vaarg - -$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.rev.simu.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.rev.hard.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -## With vaarg - -$(OUTDIR)/%.x86-gcc.vaarg.out: $(BINDIR)/%.x86-gcc.vaarg.bin - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.vaarg.simu.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.rev.vaarg.simu.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.vaarg.simu.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.vaarg.hard.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.rev.vaarg.hard.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.vaarg.hard.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -## -# Object to binary -## - -## common - -$(BINDIR)/$(COMMON).x86-gcc.bin: $(OBJDIR)/$(COMMON).x86-gcc.o $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $< -o $@ - -$(BINDIR)/$(COMMON).gcc.bin: $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $< -o $@ - -$(BINDIR)/$(COMMON).ccomp.bin: $(OBJDIR)/$(COMMON).ccomp.o $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $< -o $@ - -## vaarg_common - -$(BINDIR)/$(VAARG_COMMON).x86-gcc.bin: $(OBJDIR)/$(VAARG_COMMON).x86-gcc.o $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $< -o $@ - -$(BINDIR)/$(VAARG_COMMON).gcc.bin: $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $< -o $@ - -$(BINDIR)/$(VAARG_COMMON).ccomp.bin: $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $< -o $@ - -## no vaarg - -$(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(COMMON).x86-gcc.o $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).gcc.o $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.gcc.rev.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(COMMON).ccomp.o $(KVXCPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.ccomp.bin: $(OBJDIR)/%.ccomp.o $(OBJDIR)/$(COMMON).gcc.o $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -## with vaarg - -$(BINDIR)/%.x86-gcc.vaarg.bin: $(OBJDIR)/%.x86-gcc.o $(OBJDIR)/$(VAARG_COMMON).x86-gcc.o $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.gcc.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.gcc.rev.vaarg.bin: $(OBJDIR)/%.gcc.o $(OBJDIR)/$(VAARG_COMMON).ccomp.o $(KVXCPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -$(BINDIR)/%.ccomp.vaarg.bin: $(OBJDIR)/%.ccomp.o $(OBJDIR)/$(VAARG_COMMON).gcc.o $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $(wordlist 1,2,$^) -o $@ - -## -# Assembly to object -## - -$(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) - @mkdir -p $(@D) - $(CC) -c $(CFLAGS) $< -o $@ - -$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) -c $(CFLAGS) $< -o $@ - -$(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) -c $(CFLAGS) $< -o $@ - - -## -# Source to assembly -## - -$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) -S $< -o $@ diff --git a/test/mppa/interop/common.c b/test/mppa/interop/common.c deleted file mode 100644 index 05b49187..00000000 --- a/test/mppa/interop/common.c +++ /dev/null @@ -1,257 +0,0 @@ -#define STACK int a[100];\ - a[42] = 42; - -#define ONEARG_OP(arg) (3*magic(arg)+2) - -#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4) - -#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\ - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\ - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\ - (a0 * a1 * a2 * magic(a3) * a4 * a5 * a6 * a7 * a8 * a9 *\ - a10 * a11 * a12 * a13 * a14 * a15 * a16 * a17 * a18 * a19 *\ - a20 * a21 * a22 * a23 * a24 * a25 * a26 * a27 * a28 * a29) - -int magic(long a){ - return a*42 + 26; -} - -void void_void(){ - STACK; -} - -long long ll_void(){ - STACK; - return 0xdeadbeefdeadbeefULL; -} - -int i_oneiarg(int arg){ - STACK; - return ONEARG_OP(arg); -} - -int i_multiiargs(int arg1, char arg2, char arg3, int arg4){ - STACK; - return MULTIARG_OP(arg1, arg2, arg3, arg4); -} - -int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, - char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, - char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29) -{ - STACK; - return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); -} - -int ll_onellarg(long long arg){ - STACK; - return ONEARG_OP(arg); -} - -long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4){ - STACK; - return MULTIARG_OP(arg1, arg2, arg3, arg4); -} - -long long ll_manyllargs(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, - char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, - char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) -{ - STACK; - return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); -} - -double stackhell(char a0, int a1, float a2, long long a3, double a4, char a5, long long a6, long long a7, float a8, long long a9, - double a10, long long a11, char a12, int a13, float a14, double a15, long long a16, long long a17, float a18, long long a19, - char a20, int a21, char a22, long long a23, float a24, char a25, long long a26, int a27, double a28, long long a29) -{ - long long b0 = a0; - long long b1 = a1 * b0; - long long b2 = a2 * b1; - float b3 = a3 * b2; - int b4 = a4 * b3; - double b5 = a5 * b4; - int b6 = a6 * b5; - float b7 = a7 * b6; - char b8 = a8 * b7; - double b9 = a9 * b8; - char b10 = a10 * b9; - float b11 = a11 * b10; - char b12 = a12 * b11; - int b13 = a13 * b12; - long long b14 = a14 * b13; - long long b15 = a15 * b14; - long long b16 = a16 * b15; - long long b17 = a17 * b16; - long long b18 = a18 * b17; - long long b19 = a19 * b18; - long long b20 = a20 * b19; - long long b21 = a21 * b20; - long long b22 = a22 * b21; - long long b23 = a23 * b22; - long long b24 = a24 * b23; - long long b25 = a25 * b24; - long long b26 = a26 * b25; - long long b27 = a27 * b26; - int b28 = a28 * b27; - double b29 = a29 * b28; - float b30 = b0 * b29; - double b31 = b1 * b30; - int b32 = b2 * b31; - char b33 = b3 * b32; - float b34 = b4 * b33; - char b35 = b5 * b34; - double b36 = b6 * b35; - float b37 = b7 * b36; - int b38 = b8 * b37; - double b39 = b9 * b38; - float b40 = b0 * b39; - int b41 = b1 * b40; - double b42 = b2 * b41; - float b43 = b3 * b42; - int b44 = b4 * b43; - double b45 = b5 * b44; - int b46 = b6 * b45; - double b47 = b7 * b46; - int b48 = b8 * b47; - long long b49 = b9 * b48; - long long b50 = b0 * b49; - long long b51 = b1 * b50; - long long b52 = b2 * b51; - long long b53 = b3 * b52; - long long b54 = b4 * b53; - long long b55 = b5 * b54; - long long b56 = b6 * b55; - long long b57 = b7 * b56; - int b58 = b8 * b57; - float b59 = b9 * b58; - int b60 = b0 * b59; - float b61 = b1 * b60; - float b62 = b2 * b61; - int b63 = b3 * b62; - double b64 = b4 * b63; - int b65 = b5 * b64; - int b66 = b6 * b65; - double b67 = b7 * b66; - double b68 = b8 * b67; - int b69 = b9 * b68; - char b70 = b0 * b69; - char b71 = b1 * b70; - double b72 = b2 * b71; - double b73 = b3 * b72; - char b74 = b4 * b73; - float b75 = b5 * b74; - float b76 = b6 * b75; - double b77 = b7 * b76; - char b78 = b8 * b77; - float b79 = b9 * b78; - float b80 = b0 * b79; - char b81 = b1 * b80; - char b82 = b2 * b81; - float b83 = b3 * b82; - char b84 = b4 * b83; - int b85 = b5 * b84; - int b86 = b6 * b85; - double b87 = b7 * b86; - float b88 = b8 * b87; - double b89 = b9 * b88; - int b90 = b0 * b89; - float b91 = b1 * b90; - double b92 = b2 * b91; - int b93 = b3 * b92; - int b94 = b4 * b93; - long long b95 = b5 * b94; - long long b96 = b6 * b95; - long long b97 = b7 * b96; - long long b98 = b8 * b97; - long long b99 = b9 * b98; - long long b100 = b0 * b99; - long long b101 = b1 * b100; - long long b102 = b2 * b101; - long long b103 = b3 * b102; - long long b104 = b4 * b103; - long long b105 = b5 * b104; - long long b106 = b6 * b105; - long long b107 = b7 * b106; - long long b108 = b8 * b107; - long long b109 = b9 * b108; - long long b110 = b0 * b109; - long long b111 = b1 * b110; - long long b112 = b2 * b111; - long long b113 = b3 * b112; - long long b114 = b4 * b113; - int b115 = b5 * b114; - int b116 = b6 * b115; - int b117 = b7 * b116; - float b118 = b8 * b117; - float b119 = b9 * b118; - int b120 = b0 * b119; - double b121 = b1 * b120; - float b122 = b2 * b121; - int b123 = b3 * b122; - double b124 = b4 * b123; - int b125 = b5 * b124; - char b126 = b6 * b125; - double b127 = b7 * b126; - char b128 = b8 * b127; - float b129 = b9 * b128; - char b130 = b0 * b129; - double b131 = b1 * b130; - char b132 = b2 * b131; - float b133 = b3 * b132; - char b134 = b4 * b133; - double b135 = b5 * b134; - char b136 = b6 * b135; - float b137 = b7 * b136; - char b138 = b8 * b137; - double b139 = b9 * b138; - char b140 = b0 * b139; - float b141 = b1 * b140; - char b142 = b2 * b141; - double b143 = b3 * b142; - char b144 = b4 * b143; - float b145 = b5 * b144; - char b146 = b6 * b145; - double b147 = b7 * b146; - int b148 = b8 * b147; - float b149 = b9 * b148; - int b150 = b0 * b149; - double b151 = b1 * b150; - int b152 = b2 * b151; - float b153 = b3 * b152; - int b154 = b4 * b153; - double b155 = b5 * b154; - int b156 = b6 * b155; - float b157 = b7 * b156; - int b158 = b8 * b157; - double b159 = b9 * b158; - int b160 = b0 * b159; - float b161 = b1 * b160; - int b162 = b2 * b161; - return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) - * b0 * b1 * b2 * b3 * b4 * b5 * b6 * b7 * b8 * b9 - * b10 * b11 * b12 * b13 * b14 * b15 * b16 * b17 * b18 * b19 - * b20 * b21 * b22 * b23 * b24 * b25 * b26 * b27 * b28 * b29 - * b30 * b31 * b32 * b33 * b34 * b35 * b36 * b37 * b38 * b39 - * b40 * b41 * b42 * b43 * b44 * b45 * b46 * b47 * b48 * b49 - * b50 * b51 * b52 * b53 * b54 * b55 * b56 * b57 * b58 * b59 - * b60 * b61 * b62 * b63 * b64 * b65 * b66 * b67 * b68 * b69 - * b70 * b71 * b72 * b73 * b74 * b75 * b76 * b77 * b78 * b79 - * b80 * b81 * b82 * b83 * b84 * b85 * b86 * b87 * b88 * b89 - * b90 * b91 * b92 * b93 * b94 * b95 * b96 * b97 * b98 * b99 - * b100 * b101 * b102 * b103 * b104 * b105 * b106 * b107 * b108 * b109 - * b110 * b111 * b112 * b113 * b114 * b115 * b116 * b117 * b118 * b119 - * b120 * b121 * b122 * b123 * b124 * b125 * b126 * b127 * b128 * b129 - * b130 * b131 * b132 * b133 * b134 * b135 * b136 * b137 * b138 * b139 - * b140 * b141 * b142 * b143 * b144 * b145 * b146 * b147 * b148 * b149 - * b150 * b151 * b152 * b153 * b154 * b155 * b156 * b157 * b158 * b159 - * b160 * b161 * b162 - ; -} - diff --git a/test/mppa/interop/common.h b/test/mppa/interop/common.h deleted file mode 100644 index 055ce7ea..00000000 --- a/test/mppa/interop/common.h +++ /dev/null @@ -1,28 +0,0 @@ -#ifndef __COMMON_H__ -#define __COMMON_H__ - -void void_void(void); - -long long ll_void(void); - -int i_oneiarg(int arg); - -int i_multiiargs(int arg1, char arg2, char arg3, int arg4); - -int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, - char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, - char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29); - -int ll_onellarg(long long arg); - -long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4); - -long long ll_manyllargs(char a0, long long a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, - char a10, long long a11, char a12, long long a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, - char a20, long long a21, char a22, long long a23, char a24, char a25, long long a26, long long a27, char a28, long long a29); - -double stackhell(char a0, long long a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, - char a10, long long a11, char a12, long long a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, - char a20, long long a21, char a22, long long a23, char a24, char a25, long long a26, long long a27, char a28, long long a29); - -#endif diff --git a/test/mppa/interop/framework.h b/test/mppa/interop/framework.h deleted file mode 100644 index 3bbfa271..00000000 --- a/test/mppa/interop/framework.h +++ /dev/null @@ -1,66 +0,0 @@ -#ifndef __FRAMEWORK_H__ -#define __FRAMEWORK_H__ - -#include -#include "../prng/prng.c" - -#define BEGIN_TEST_N(type, N)\ - int main(void){\ - type t[N], c, i, j, S;\ - srand(0);\ - S = 0;\ - for (i = 0 ; i < 100 ; i++){\ - c = randlong();\ - for (j = 0 ; j < N ; j++)\ - t[j] = randlong();\ - /* END BEGIN_TEST_N */ - -#define BEGIN_TEST(type)\ - int main(void){\ - type a, b, c, S;\ - int i;\ - srand(0);\ - S = 0;\ - for (i = 0 ; i < 100 ; i++){\ - c = randlong();\ - a = randlong();\ - b = randlong(); - /* END BEGIN_TEST */ - -/* In between BEGIN_TEST and END_TEST : definition of c */ - -#define END_TEST64()\ - printf("%llu\t%llu\t%llu\n", a, b, c);\ - S += c;\ - }\ - return S;\ - } - /* END END_TEST64 */ - -#define END_TEST32()\ - printf("%u\t%u\t%u\n", a, b, c);\ - S += c;\ - }\ - return S;\ - } - /* END END_TEST32 */ - -#define END_TESTF32()\ - printf("%e\t%e\t%e\n", a, b, c);\ - S += c;\ - }\ - return 0;\ - } - /* END END_TESTF32 */ - -#define END_TESTF64()\ - printf("%e\t%e\t%e\n", a, b, c);\ - S += c;\ - }\ - return 0;\ - } - /* END END_TESTF64 */ - -#endif - - diff --git a/test/mppa/interop/i32.c b/test/mppa/interop/i32.c deleted file mode 100644 index 6bc2705c..00000000 --- a/test/mppa/interop/i32.c +++ /dev/null @@ -1,13 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(int) - c = i_manyiargs(a, b, a-b, a+b, a*2, b*2, a*2-b, a+b*2, (a-b)*2, (a+b)*2, - -2*a, -2*b, a-b, a+b, a*3, b*3, a*3-b, a+b*3, (a-b)*3, (a+b)*3, - -3*a, -3*b, a-b, a+b, a*4, b*4, a*4-b, a+b*4, (a-b)*4, (a+b)*4); - c += i_multiiargs(a, b, a-b, a+b); - c += i_oneiarg(a); - void_void(); - c += a; -END_TEST32() - diff --git a/test/mppa/interop/i64.c b/test/mppa/interop/i64.c deleted file mode 100644 index 3e7240f7..00000000 --- a/test/mppa/interop/i64.c +++ /dev/null @@ -1,14 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(long long) - c = ll_manyllargs(a, b, a-b, a+b, a*2, b*2, a*2-b, a+b*2, (a-b)*2, (a+b)*2, - -2*a, -2*b, a-b, a+b, a*3, b*3, a*3-b, a+b*3, (a-b)*3, (a+b)*3, - -3*a, -3*b, a-b, a+b, a*4, b*4, a*4-b, a+b*4, (a-b)*4, (a+b)*4); - c += ll_multillargs(a, b, a-b, a+b); - c += ll_onellarg(a); - c = ll_void(); - c += a; - void_void(); - c += a; -END_TEST64() diff --git a/test/mppa/interop/individual/i_multiiargs.c b/test/mppa/interop/individual/i_multiiargs.c deleted file mode 100644 index 888742b5..00000000 --- a/test/mppa/interop/individual/i_multiiargs.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(int) - c = i_multiiargs(a, b, a-b, a+b); -END_TEST32() diff --git a/test/mppa/interop/individual/i_oneiarg.c b/test/mppa/interop/individual/i_oneiarg.c deleted file mode 100644 index 9c969fb8..00000000 --- a/test/mppa/interop/individual/i_oneiarg.c +++ /dev/null @@ -1,6 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(int) - c = i_oneiarg(a); -END_TEST32() diff --git a/test/mppa/interop/individual/ll_multillargs.c b/test/mppa/interop/individual/ll_multillargs.c deleted file mode 100644 index 34b422eb..00000000 --- a/test/mppa/interop/individual/ll_multillargs.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(long long) - c = ll_multillargs(a, b, a-b, a+b); -END_TEST64() - diff --git a/test/mppa/interop/individual/ll_onellarg.c b/test/mppa/interop/individual/ll_onellarg.c deleted file mode 100644 index a2fbbbe9..00000000 --- a/test/mppa/interop/individual/ll_onellarg.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(long long) - c = ll_onellarg(a); -END_TEST64() - diff --git a/test/mppa/interop/individual/ll_void.c b/test/mppa/interop/individual/ll_void.c deleted file mode 100644 index da128fdd..00000000 --- a/test/mppa/interop/individual/ll_void.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(long long) - c = ll_void(); - c += a; -END_TEST64() diff --git a/test/mppa/interop/individual/void_void.c b/test/mppa/interop/individual/void_void.c deleted file mode 100644 index 976a721b..00000000 --- a/test/mppa/interop/individual/void_void.c +++ /dev/null @@ -1,7 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(long long) - void_void(); - c = a; -END_TEST64() diff --git a/test/mppa/interop/stackhell.c b/test/mppa/interop/stackhell.c deleted file mode 100644 index 5abaa71d..00000000 --- a/test/mppa/interop/stackhell.c +++ /dev/null @@ -1,9 +0,0 @@ -#include "framework.h" -#include "common.h" - -BEGIN_TEST(double) - c = stackhell(a, b, a*b, a*b, a*2, b*2, a*2*b, a*b*2, (a*b)*2, (a*b)*2, - 2*a, 2*b, a*b, a*b, a*3, b*3, a*3*b, a*b*3, (a*b)*3, (a*b)*3, - 3*a, 3*b, a*b, a*b, a*4, b*4, a*4*b, a*b*4, (a*b)*4, (a*b)*4); - -END_TESTF64() diff --git a/test/mppa/interop/vaarg_common.c b/test/mppa/interop/vaarg_common.c deleted file mode 100644 index 3314959f..00000000 --- a/test/mppa/interop/vaarg_common.c +++ /dev/null @@ -1,383 +0,0 @@ -#include - -#define STACK int a[100];\ - a[42] = 42; - -#define ONEARG_OP(arg) (3*magic(arg)+2) - -#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4) - -#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\ - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\ - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\ - (a0 + a1 * a2 + magic(a3) * a4 + a5 + a6 + a7 - a8 + a9 +\ - a10 + a11 - a12 ^ a13 + a14 - magic(a15) + a16 ^ a17 + a18 + a19 +\ - a20 + a21 + a22 * a23 + a24 + a25 << a26 & a27 + a28 + a29) - -#define VA_START(vl, arg) va_list vl; va_start(vl, arg) -#define VA_END(vl) va_end(vl) - -int magic(long a){ - return a*2 + 42; -} - -void void_void(void){ - STACK; -} - -long long ll_void(void){ - STACK; - return 0xdeadbeefdeadbeefULL; -} - -// int i_oneiarg(int arg){ -int i_oneiarg(int arg, ...){ - STACK; - VA_START(vl, arg); - VA_END(vl); - return ONEARG_OP(arg); -} - -//int i_multiiargs(int arg1, char arg2, char arg3, int arg4){ -int i_multiiargs(int arg1, ...){ - STACK; - VA_START(vl, arg1); - char arg2 = va_arg(vl, int); - char arg3 = va_arg(vl, int); - int arg4 = va_arg(vl, int); - VA_END(vl); - return MULTIARG_OP(arg1, arg2, arg3, arg4); -} - -//int i_manyiargs(char a0, int a1, char a2, int a3, char a4, char a5, int a6, int a7, char a8, int a9, -// char a10, int a11, char a12, int a13, char a14, char a15, int a16, int a17, char a18, int a19, -// char a20, int a21, char a22, int a23, char a24, char a25, int a26, int a27, char a28, int a29) -int i_manyiargs(char a0, ...) -{ - STACK; - VA_START(vl, a0); - VA_START(vl2, a0); - int a1 = va_arg(vl, int); - char a2 = va_arg(vl, int); - int a3 = va_arg(vl, int); - char a4 = va_arg(vl, int); - char a5 = va_arg(vl, int); - char b1 = va_arg(vl2, int); - int a6 = va_arg(vl, int); - int a7 = va_arg(vl, int); - char a8 = va_arg(vl, int); - char b2 = va_arg(vl2, int); - int a9 = va_arg(vl, int); - char a10 = va_arg(vl, int); - int a11 = va_arg(vl, int); - char a12 = va_arg(vl, int); - char b3 = va_arg(vl2, int); - int a13 = va_arg(vl, int); - char a14 = va_arg(vl, int); - char a15 = va_arg(vl, int); - int a16 = va_arg(vl, int); - int a17 = va_arg(vl, int); - char a18 = va_arg(vl, int); - int a19 = va_arg(vl, int); - char a20 = va_arg(vl, int); - int a21 = va_arg(vl, int); - char a22 = va_arg(vl, int); - int a23 = va_arg(vl, int); - char a24 = va_arg(vl, int); - char a25 = va_arg(vl, int); - int a26 = va_arg(vl, int); - char b4 = va_arg(vl2, int); - int a27 = va_arg(vl, int); - char a28 = va_arg(vl, int); - int a29 = va_arg(vl, int); - VA_END(vl); - VA_END(vl); - return MANYARG_OP(a0, a1, a2, a3, a4, (a5*b2), a6, a7, a8, a9, - (a10*b3), a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, (a21*b1), a22, a23, (a24*b3), a25, a26, a27, a28, a29); -} - -//int ll_onellarg(long long arg){ -int ll_onellarg(long long arg, ...){ - STACK; - VA_START(vl, arg); - VA_END(vl); - return ONEARG_OP(arg); -} - -//long long ll_multillargs(long long arg1, char arg2, char arg3, long long arg4){ -long long ll_multillargs(long long arg1, ...){ - STACK; - VA_START(vl, arg1); - char arg2 = va_arg(vl, int); - char arg3 = va_arg(vl, int); - long long arg4 = va_arg(vl, long long); - VA_END(vl); - return MULTIARG_OP(arg1, arg2, arg3, arg4); -} - -//long long ll_manyllargs(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, -// char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, -// char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) -long long ll_manyllargs(char a0, ...) -{ - STACK; - VA_START(vl, a0); - int a1 = va_arg(vl, int); - char a2 = va_arg(vl, int); - long long a3 = va_arg(vl, long long); - char a4 = va_arg(vl, int); - char a5 = va_arg(vl, int); - long long a6 = va_arg(vl, long long); - long long a7 = va_arg(vl, long long); - char a8 = va_arg(vl, int); - long long a9 = va_arg(vl, long long); - char a10 = va_arg(vl, int); - long long a11 = va_arg(vl, long long); - char a12 = va_arg(vl, int); - int a13 = va_arg(vl, int); - char a14 = va_arg(vl, int); - char a15 = va_arg(vl, int); - long long a16 = va_arg(vl, long long); - long long a17 = va_arg(vl, long long); - char a18 = va_arg(vl, int); - long long a19 = va_arg(vl, long long); - char a20 = va_arg(vl, int); - int a21 = va_arg(vl, int); - char a22 = va_arg(vl, int); - long long a23 = va_arg(vl, long long); - char a24 = va_arg(vl, int); - char a25 = va_arg(vl, int); - long long a26 = va_arg(vl, long long); - int a27 = va_arg(vl, int); - char a28 = va_arg(vl, int); - long long a29 = va_arg(vl, long long); - VA_END(vl); - return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29); -} - -//long long stackhell(char a0, int a1, char a2, long long a3, char a4, char a5, long long a6, long long a7, char a8, long long a9, -// char a10, long long a11, char a12, int a13, char a14, char a15, long long a16, long long a17, char a18, long long a19, -// char a20, int a21, char a22, long long a23, char a24, char a25, long long a26, int a27, char a28, long long a29) -long long stackhell(char a0, ...) -{ - VA_START(vl, a0); - int a1 = va_arg(vl, int); - char a2 = va_arg(vl, int); - long long a3 = va_arg(vl, long long); - char a4 = va_arg(vl, int); - char a5 = va_arg(vl, int); - long long a6 = va_arg(vl, long long); - long long a7 = va_arg(vl, long long); - char a8 = va_arg(vl, int); - long long a9 = va_arg(vl, long long); - char a10 = va_arg(vl, int); - long long a11 = va_arg(vl, long long); - char a12 = va_arg(vl, int); - int a13 = va_arg(vl, int); - char a14 = va_arg(vl, int); - char a15 = va_arg(vl, int); - long long a16 = va_arg(vl, long long); - long long a17 = va_arg(vl, long long); - char a18 = va_arg(vl, int); - long long a19 = va_arg(vl, long long); - char a20 = va_arg(vl, int); - int a21 = va_arg(vl, int); - char a22 = va_arg(vl, int); - long long a23 = va_arg(vl, long long); - char a24 = va_arg(vl, int); - char a25 = va_arg(vl, int); - long long a26 = va_arg(vl, long long); - int a27 = va_arg(vl, int); - char a28 = va_arg(vl, int); - long long a29 = va_arg(vl, long long); - VA_END(vl); - - long long b0 = a0; - long long b1 = a1 + b0; - long long b2 = a2 + b1; - int b3 = a3 + b2; - int b4 = a4 + b3; - int b5 = a5 + b4; - int b6 = a6 + b5; - int b7 = a7 + b6; - char b8 = a8 + b7; - char b9 = a9 + b8; - char b10 = a10 + b9; - char b11 = a11 + b10; - char b12 = a12 + b11; - int b13 = a13 + b12; - long long b14 = a14 + b13; - long long b15 = a15 + b14; - long long b16 = a16 + b15; - long long b17 = a17 + b16; - long long b18 = a18 + b17; - long long b19 = a19 + b18; - long long b20 = a20 + b19; - long long b21 = a21 + b20; - long long b22 = a22 + b21; - long long b23 = a23 + b22; - long long b24 = a24 + b23; - long long b25 = a25 + b24; - long long b26 = a26 + b25; - long long b27 = a27 + b26; - int b28 = a28 + b27; - int b29 = a29 + b28; - int b30 = b0 + b29; - int b31 = b1 + b30; - int b32 = b2 + b31; - char b33 = b3 + b32; - char b34 = b4 + b33; - char b35 = b5 + b34; - char b36 = b6 + b35; - char b37 = b7 + b36; - int b38 = b8 + b37; - int b39 = b9 + b38; - int b40 = b0 + b39; - int b41 = b1 + b40; - int b42 = b2 + b41; - int b43 = b3 + b42; - int b44 = b4 + b43; - int b45 = b5 + b44; - int b46 = b6 + b45; - int b47 = b7 + b46; - int b48 = b8 + b47; - long long b49 = b9 + b48; - long long b50 = b0 + b49; - long long b51 = b1 + b50; - long long b52 = b2 + b51; - long long b53 = b3 + b52; - long long b54 = b4 + b53; - long long b55 = b5 + b54; - long long b56 = b6 + b55; - long long b57 = b7 + b56; - int b58 = b8 + b57; - int b59 = b9 + b58; - int b60 = b0 + b59; - int b61 = b1 + b60; - int b62 = b2 + b61; - int b63 = b3 + b62; - int b64 = b4 + b63; - int b65 = b5 + b64; - int b66 = b6 + b65; - int b67 = b7 + b66; - int b68 = b8 + b67; - int b69 = b9 + b68; - char b70 = b0 + b69; - char b71 = b1 + b70; - char b72 = b2 + b71; - char b73 = b3 + b72; - char b74 = b4 + b73; - char b75 = b5 + b74; - char b76 = b6 + b75; - char b77 = b7 + b76; - char b78 = b8 + b77; - char b79 = b9 + b78; - char b80 = b0 + b79; - char b81 = b1 + b80; - char b82 = b2 + b81; - char b83 = b3 + b82; - char b84 = b4 + b83; - int b85 = b5 + b84; - int b86 = b6 + b85; - int b87 = b7 + b86; - int b88 = b8 + b87; - int b89 = b9 + b88; - int b90 = b0 + b89; - int b91 = b1 + b90; - int b92 = b2 + b91; - int b93 = b3 + b92; - int b94 = b4 + b93; - long long b95 = b5 + b94; - long long b96 = b6 + b95; - long long b97 = b7 + b96; - long long b98 = b8 + b97; - long long b99 = b9 + b98; - long long b100 = b0 + b99; - long long b101 = b1 + b100; - long long b102 = b2 + b101; - long long b103 = b3 + b102; - long long b104 = b4 + b103; - long long b105 = b5 + b104; - long long b106 = b6 + b105; - long long b107 = b7 + b106; - long long b108 = b8 + b107; - long long b109 = b9 + b108; - long long b110 = b0 + b109; - long long b111 = b1 + b110; - long long b112 = b2 + b111; - long long b113 = b3 + b112; - long long b114 = b4 + b113; - int b115 = b5 + b114; - int b116 = b6 + b115; - int b117 = b7 + b116; - int b118 = b8 + b117; - int b119 = b9 + b118; - int b120 = b0 + b119; - int b121 = b1 + b120; - int b122 = b2 + b121; - int b123 = b3 + b122; - int b124 = b4 + b123; - int b125 = b5 + b124; - char b126 = b6 + b125; - char b127 = b7 + b126; - char b128 = b8 + b127; - char b129 = b9 + b128; - char b130 = b0 + b129; - char b131 = b1 + b130; - char b132 = b2 + b131; - char b133 = b3 + b132; - char b134 = b4 + b133; - char b135 = b5 + b134; - char b136 = b6 + b135; - char b137 = b7 + b136; - char b138 = b8 + b137; - char b139 = b9 + b138; - char b140 = b0 + b139; - char b141 = b1 + b140; - char b142 = b2 + b141; - char b143 = b3 + b142; - char b144 = b4 + b143; - char b145 = b5 + b144; - char b146 = b6 + b145; - char b147 = b7 + b146; - int b148 = b8 + b147; - int b149 = b9 + b148; - int b150 = b0 + b149; - int b151 = b1 + b150; - int b152 = b2 + b151; - int b153 = b3 + b152; - int b154 = b4 + b153; - int b155 = b5 + b154; - int b156 = b6 + b155; - int b157 = b7 + b156; - int b158 = b8 + b157; - int b159 = b9 + b158; - int b160 = b0 + b159; - int b161 = b1 + b160; - int b162 = b2 + b161; - return MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, - a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, - a20, a21, a22, a23, a24, a25, a26, a27, a28, a29) - + b0 + b1 + b2 + b3 + b4 + b5 + b6 + b7 + b8 + b9 - + b10 + b11 + b12 + b13 + b14 + b15 + b16 + b17 + b18 + b19 - + b20 + b21 + b22 + b23 + b24 + b25 + b26 + b27 + b28 + b29 - + b30 + b31 + b32 + b33 + b34 + b35 + b36 + b37 + b38 + b39 - + b40 + b41 + b42 + b43 + b44 + b45 + b46 + b47 + b48 + b49 - + b50 + b51 + b52 + b53 + b54 + b55 + b56 + b57 + b58 + b59 - + b60 + b61 + b62 + b63 + b64 + b65 + b66 + b67 + b68 + b69 - + b70 + b71 + b72 + b73 + b74 + b75 + b76 + b77 + b78 + b79 - + b80 + b81 + b82 + b83 + b84 + b85 + b86 + b87 + b88 + b89 - + b90 + b91 + b92 + b93 + b94 + b95 + b96 + b97 + b98 + b99 - + b100 + b101 + b102 + b103 + b104 + b105 + b106 + b107 + b108 + b109 - + b110 + b111 + b112 + b113 + b114 + b115 + b116 + b117 + b118 + b119 - + b120 + b121 + b122 + b123 + b124 + b125 + b126 + b127 + b128 + b129 - + b130 + b131 + b132 + b133 + b134 + b135 + b136 + b137 + b138 + b139 - + b140 + b141 + b142 + b143 + b144 + b145 + b146 + b147 + b148 + b149 - + b150 + b151 + b152 + b153 + b154 + b155 + b156 + b157 + b158 + b159 - + b160 + b161 + b162 - ; -} - diff --git a/test/mppa/lib/Makefile b/test/mppa/lib/Makefile deleted file mode 100644 index 5a947bb3..00000000 --- a/test/mppa/lib/Makefile +++ /dev/null @@ -1,133 +0,0 @@ -KVXC ?= k1-cos-gcc -K1AR ?= k1-cos-ar -CC ?= gcc -AR ?= gcc-ar -CCOMP ?= ccomp -CFLAGS ?= -O1 -Wl,--wrap=printf -SIMU ?= k1-mppa -TIMEOUT ?= --signal=SIGTERM 60s - -DIR=./ -SRCDIR=$(DIR) -OUTDIR=$(DIR)/out -BINDIR=$(DIR)/bin -ASMDIR=$(DIR)/asm -OBJDIR=$(DIR)/obj - -KVXCPATH=$(shell which $(KVXC)) -K1ARPATH=$(shell which $(K1AR)) -CCPATH=$(shell which $(CC)) -ARPATH=$(shell which $(AR)) -SIMUPATH=$(shell which $(SIMU)) - -TESTNAMES=printf-test -X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES))) -GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES))) -CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES))) - -OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT) -BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\ - $(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES))) - -## -# Targets -## - -all: $(BIN) system.x86-gcc.a system.gcc.a - -.PHONY: -test: $(X86_GCC_OUT) $(GCC_OUT) - @echo "Comparing x86 gcc output to k1 gcc.." - @for test in $(TESTNAMES); do\ - x86out=$(OUTDIR)/$$test.x86-gcc.out;\ - gccout=$(OUTDIR)/$$test.gcc.out;\ - if ! diff $$x86out $$gccout; then\ - >&2 echo "ERROR: $$x86out and $$gccout differ";\ - else\ - echo "GOOD: $$x86out and $$gccout concur";\ - fi;\ - done - -.PHONY: -check: $(GCC_OUT) $(CCOMP_OUT) - @echo "Comparing k1 gcc output to ccomp.." - @for test in $(TESTNAMES); do\ - gccout=$(OUTDIR)/$$test.gcc.out;\ - ccompout=$(OUTDIR)/$$test.ccomp.out;\ - if ! diff $$ccompout $$gccout; then\ - >&2 echo "ERROR: $$ccompout and $$gccout differ";\ - else\ - echo "GOOD: $$ccompout and $$gccout concur";\ - fi;\ - done - -## -# Rules -## - -.SECONDARY: - -# Generating output - -## Version avec timeout -$(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH) - @mkdir -p $(@D) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -# Object to binary - -$(BINDIR)/%.x86-gcc.bin: $(OBJDIR)/%.x86-gcc.o system.x86-gcc.a $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -$(BINDIR)/%.gcc.bin: $(OBJDIR)/%.gcc.o system.gcc.a $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ - -$(BINDIR)/%.ccomp.bin: $(OBJDIR)/%.ccomp.o system.gcc.a $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ - -# Generating libraries -system.x86-gcc.a: $(OBJDIR)/printf.x86-gcc.o $(ARPATH) - $(AR) rcs $@ $< - -system.gcc.a: $(OBJDIR)/printf.gcc.o $(K1ARPATH) - $(K1AR) rcs $@ $< - -# Assembly to object - -$(OBJDIR)/%.x86-gcc.o: $(ASMDIR)/%.x86-gcc.s $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) -c $< -o $@ - -$(OBJDIR)/%.gcc.o: $(ASMDIR)/%.gcc.s $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) -c $< -o $@ - -$(OBJDIR)/%.ccomp.o: $(ASMDIR)/%.ccomp.s $(CCOMPPATH) - $(CCOMP) $(CFLAGS) -c $< -o $@ - -# Source to assembly - -$(ASMDIR)/%.x86-gcc.s: $(SRCDIR)/%.c $(CCPATH) - @mkdir -p $(@D) - $(CC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(KVXCPATH) - @mkdir -p $(@D) - $(KVXC) $(CFLAGS) -S $< -o $@ - -$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH) - @mkdir -p $(@D) - $(CCOMP) $(CFLAGS) -S $< -o $@ - diff --git a/test/mppa/lib/printf-test.c b/test/mppa/lib/printf-test.c deleted file mode 100644 index 25afd436..00000000 --- a/test/mppa/lib/printf-test.c +++ /dev/null @@ -1,9 +0,0 @@ -int printf(const char *, ...); - -int main(void){ - int a = 42; - char *str = "Hi there"; - printf("%s, I am %u\n", str, a); - - return 0; -} diff --git a/test/mppa/lib/printf.c b/test/mppa/lib/printf.c deleted file mode 100644 index 79984ef6..00000000 --- a/test/mppa/lib/printf.c +++ /dev/null @@ -1,9 +0,0 @@ -#include -#include - -int __wrap_printf(const char *format, ...){ - va_list args; - va_start(args, format); - vprintf(format, args); - va_end(args); -} diff --git a/test/mppa/mmult/.gitignore b/test/mppa/mmult/.gitignore deleted file mode 100644 index b43ccc5f..00000000 --- a/test/mppa/mmult/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -mmult-test-ccomp-kvx -mmult-test-gcc-kvx -mmult-test-gcc-x86 -.zero diff --git a/test/mppa/mmult/Makefile b/test/mppa/mmult/Makefile deleted file mode 100644 index e7cd890e..00000000 --- a/test/mppa/mmult/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -KVXC ?= k1-cos-gcc -CC ?= gcc -CCOMP ?= ccomp -CFLAGS ?= -O2 -SIMU ?= k1-mppa -TIMEOUT ?= 10s - -KVXCPATH=$(shell which $(KVXC)) -CCPATH=$(shell which $(CC)) -CCOMPPATH=$(shell which $(CCOMP)) -SIMUPATH=$(shell which $(SIMU)) - -PRNG=../prng/prng.c - -ALL= mmult-test-gcc-x86 mmult-test-gcc-kvx mmult-test-ccomp-kvx -CCOMP_OUT= mmult-test-ccomp-kvx.out -GCC_OUT= mmult-test-gcc-kvx.out -X86_GCC_OUT= mmult-test-gcc-x86.out -STUB_OUT=.zero - -all: $(ALL) - -mmult-test-gcc-x86: mmult.c $(PRNG) $(CCPATH) - $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -mmult-test-gcc-kvx: mmult.c $(PRNG) $(KVXCPATH) - $(KVXC) $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ - -mmult-test-ccomp-kvx: mmult.c $(PRNG) $(CCOMPPATH) - $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ - -.SECONDARY: -%kvx.out: %kvx $(SIMUPATH) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -%x86.out: %x86 - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -.zero: - @echo "0" > $@ - -.PHONY: -test: test-x86 test-kvx - -.PHONY: -test-x86: $(X86_GCC_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR x86: $< failed";\ - else\ - echo "GOOD x86: $< succeeded";\ - fi - -.PHONY: -test-kvx: $(GCC_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $< failed";\ - else\ - echo "GOOD kvx: $< succeeded";\ - fi - -.PHONY: -check: $(CCOMP_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $< failed";\ - else\ - echo "GOOD kvx: $< succeeded";\ - fi diff --git a/test/mppa/mmult/README.md b/test/mppa/mmult/README.md deleted file mode 100644 index 780603f6..00000000 --- a/test/mppa/mmult/README.md +++ /dev/null @@ -1,17 +0,0 @@ -MMULT -===== - -Examples of matrix multiplication using different methods. - -We compute matrix multiplication using column-based matrix multiplication, then row-based, and finally block based. - -The test verifies that the result is the same on the three methods. If it is the same, 0 will be returned. - -The following commands can be run inside the folder: - -- `make`: produces the unitary test binaries - - `mmult-test-gcc-x86` : binary from gcc on x86 - - `mmult-test-kvx-x86` : binary from gcc on kvx - - `mmult-test-ccomp-x86` : binary from ccomp on kvx -- `make test`: tests the return value of the binaries produced by gcc. -- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/mmult/mmult.c b/test/mppa/mmult/mmult.c deleted file mode 100644 index aeb91d48..00000000 --- a/test/mppa/mmult/mmult.c +++ /dev/null @@ -1,146 +0,0 @@ -#include "../prng/types.h" -#include "../prng/prng.h" - -#define __UNIT_TEST_MMULT__ - -#ifdef __UNIT_TEST_MMULT__ -#define SIZE 10 -#else -#include "test.h" -#endif - -void mmult_row(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ - int i, j, k; - - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++) - C[i][j] = 0; - - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++) - for (k = 0 ; k < SIZE ; k++) - C[i][j] += A[i][k] * B[k][j]; -} - -void mmult_col(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ - int i, j, k; - - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++) - C[i][j] = 0; - - for (k = 0 ; k < SIZE ; k++) - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++) - C[i][j] += A[i][k] * B[k][j]; -} - -typedef struct mblock { - int imin, imax, jmin, jmax; - uint64_t *mat; -} mblock; - -#define MAT_XY(mat, x, y) (mat)[(x)*SIZE + (y)] -#define MAT_IJ(block, i, j) MAT_XY((block)->mat, (block)->imin + (i), block->jmin + (j)) - -void divac_mul(mblock *C, const mblock *A, const mblock *B){ - const int size = C->imax - C->imin; - int i, j, k; - - for (i = 0 ; i < size ; i++) - for (j = 0 ; j < size ; j++) - for (k = 0 ; k < size ; k++) - MAT_IJ(C, i, j) += MAT_IJ(A, i, k) * MAT_IJ(B, k, j); -} - -#define BLOCK_X_MID(block) ((block)->imin + (block)->imax) / 2 -#define BLOCK_Y_MID(block) ((block)->jmin + (block)->jmax) / 2 - -#define MAKE_MBLOCK(newb, block, I, J) \ - mblock newb = {.mat=(block)->mat};\ - if ((I) == 0){\ - newb.imin = (block)->imin;\ - newb.imax = BLOCK_X_MID((block));\ - } else {\ - newb.imin = BLOCK_X_MID((block));\ - newb.imax = (block)->imax;\ - } if ((J) == 0){\ - newb.jmin = (block)->jmin;\ - newb.jmax = BLOCK_Y_MID((block));\ - } else {\ - newb.jmin = BLOCK_Y_MID((block));\ - newb.jmax = (block)->jmax;\ - } - -void divac_part(mblock *C, const mblock *A, const mblock *B); - -void divac_wrap(mblock *C , char IC, char JC, - const mblock *A, char IA, char JA, - const mblock *B, char IB, char JB){ - MAKE_MBLOCK(Cb, C, IC, JC); - MAKE_MBLOCK(Ab, A, IA, JA); - MAKE_MBLOCK(Bb, B, IB, JB); - - divac_part(&Cb, &Ab, &Bb); -} - - -void divac_part(mblock *C, const mblock *A, const mblock *B){ - const int size = C->imax - C->imin; - - if (size % 2 == 1) - divac_mul(C, A, B); - else{ - /* C_00 = A_00 B_00 + A_01 B_10 */ - divac_wrap(C, 0, 0, A, 0, 0, B, 0, 0); - divac_wrap(C, 0, 0, A, 0, 1, B, 1, 0); - - /* C_10 = A_10 B_00 + A_11 B_10 */ - divac_wrap(C, 1, 0, A, 1, 0, B, 0, 0); - divac_wrap(C, 1, 0, A, 1, 1, B, 1, 0); - - /* C_01 = A_00 B_01 + A_01 B_11 */ - divac_wrap(C, 0, 1, A, 0, 0, B, 0, 1); - divac_wrap(C, 0, 1, A, 0, 1, B, 1, 1); - - /* C_11 = A_10 B_01 + A_11 B_11 */ - divac_wrap(C, 1, 1, A, 1, 0, B, 0, 1); - divac_wrap(C, 1, 1, A, 1, 1, B, 1, 1); - } - -} - -void mmult_divac(uint64_t C[][SIZE], uint64_t A[][SIZE], uint64_t B[][SIZE]){ - mblock Cb = {.mat = (uint64_t *) C, .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; - mblock Ab = {.mat = (uint64_t *) A , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; - mblock Bb = {.mat = (uint64_t *) B , .imin = 0, .imax = SIZE, .jmin = 0, .jmax = SIZE}; - - divac_part(&Cb, &Ab, &Bb); -} - -#ifdef __UNIT_TEST_MMULT__ -static uint64_t C1[SIZE][SIZE], C2[SIZE][SIZE], C3[SIZE][SIZE]; -static uint64_t A[SIZE][SIZE], B[SIZE][SIZE]; - -int main(void){ - srand(42); - int i, j; - - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++){ - A[i][j] = randlong(); - B[i][j] = randlong(); - } - - mmult_row(C1, A, B); - mmult_col(C2, A, B); - mmult_divac(C3, A, B); - - for (i = 0 ; i < SIZE ; i++) - for (j = 0 ; j < SIZE ; j++) - if (!(C1[i][j] == C2[i][j] && C1[i][j] == C3[i][j])) - return -1; - - return 0; -} -#endif /* __UNIT_TEST_MMULT__ */ diff --git a/test/mppa/mmult/mmult.h b/test/mppa/mmult/mmult.h deleted file mode 100644 index 3721784a..00000000 --- a/test/mppa/mmult/mmult.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef __MMULT_H__ -#define __MMULT_H__ - -#include "../lib/types.h" - -void mmult_row(uint64_t *A, const uint64_t *B, const uint64_t *C); -void mmult_column(uint64_t *A, const uint64_t *B, const uint64_t *C); -void mmult_strassen(uint64_t *A, const uint64_t *B, const uint64_t *C); - -#endif /* __MMULT_H__ */ diff --git a/test/mppa/prng/.gitignore b/test/mppa/prng/.gitignore deleted file mode 100644 index 08023900..00000000 --- a/test/mppa/prng/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -prng-test-ccomp-kvx -prng-test-gcc-x86 -prng-test-gcc-kvx diff --git a/test/mppa/prng/Makefile b/test/mppa/prng/Makefile deleted file mode 100644 index 68e5ffc9..00000000 --- a/test/mppa/prng/Makefile +++ /dev/null @@ -1,69 +0,0 @@ -KVXC ?= k1-cos-gcc -CC ?= gcc -CCOMP ?= ccomp -CFLAGS ?= -O2 -SIMU ?= k1-mppa -TIMEOUT ?= 10s - -KVXCPATH=$(shell which $(KVXC)) -CCPATH=$(shell which $(CC)) -CCOMPPATH=$(shell which $(CCOMP)) -SIMUPATH=$(shell which $(SIMU)) - -ALL= prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx -CCOMP_OUT= prng-test-ccomp-kvx.out -GCC_OUT= prng-test-gcc-kvx.out -X86_GCC_OUT= prng-test-gcc-x86.out -STUB_OUT=.zero - -all: $(ALL) - -prng-test-gcc-x86: prng.c $(CCPATH) - $(CC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ - -prng-test-gcc-kvx: prng.c $(KVXCPATH) - $(KVXC) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ - -prng-test-ccomp-kvx: prng.c $(CCOMPPATH) - $(CCOMP) -D__UNIT_TEST_PRNG__ $(CFLAGS) $< -o $@ - -.SECONDARY: -%kvx.out: %kvx $(SIMUPATH) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -%x86.out: %x86 - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -.zero: - @echo "0" > $@ - -.PHONY: -test: test-x86 test-kvx - -.PHONY: -test-x86: $(X86_GCC_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR x86: $< failed";\ - else\ - echo "GOOD x86: $< succeeded";\ - fi - -.PHONY: -test-kvx: $(GCC_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $< failed";\ - else\ - echo "GOOD kvx: $< succeeded";\ - fi - -.PHONY: -check: $(CCOMP_OUT) $(STUB_OUT) - @if ! diff $< $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $< failed";\ - else\ - echo "GOOD kvx: $< succeeded";\ - fi - -.PHONY: -clean: - rm -f prng-test-gcc-x86 prng-test-gcc-kvx prng-test-ccomp-kvx diff --git a/test/mppa/prng/README.md b/test/mppa/prng/README.md deleted file mode 100644 index 98ed539d..00000000 --- a/test/mppa/prng/README.md +++ /dev/null @@ -1,17 +0,0 @@ -PRNG -==== - -This is a simple Pseudo Random Number Generator. - -`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" -of 1000 generated numbers to a hardcoded result, that is the one obtained with -`gcc -O2` on a x86 processor, and returns 0 if the result is correct. - -The following commands can be run inside that folder: - -- `make`: produces the unitary test binaries - - `prng-test-gcc-x86` : binary from gcc on x86 - - `prng-test-kvx-x86` : binary from gcc on kvx - - `prng-test-ccomp-x86` : binary from ccomp on kvx -- `make test`: tests the return value of the binaries produced by gcc. -- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/prng/prng.c b/test/mppa/prng/prng.c deleted file mode 100644 index 71de1dc3..00000000 --- a/test/mppa/prng/prng.c +++ /dev/null @@ -1,41 +0,0 @@ -// https://en.wikipedia.org/wiki/Linear_congruential_generator -> MMIX Donald Knuth -// modulo 2^64 = no need to do it explicitly - -#include "types.h" - -#define MULTIPLIER 6364136223846793005LL -#define INCREMENT 1442695040888963407LL - -static uint64_t current; - -void srand(uint64_t seed){ - current = seed; -} - -uint64_t randlong(void){ - return (current = MULTIPLIER * current + INCREMENT); -} - -#ifdef __UNIT_TEST_PRNG__ -char bytewise_sum(uint64_t to_check){ - char sum = 0; - int i; - - for (i = 0 ; i < 8 ; i++) - sum += (to_check & (uint64_t)(0xFFULL << i*8)) >> i*8; - - return sum; -} - -int main(void){ - srand(42); - int i; - - for (i = 0 ; i < 1000 ; i++) - randlong(); - - uint64_t last = randlong(); - - return !((unsigned char)bytewise_sum(last) == 155); -} -#endif // __UNIT_TEST_PRNG__ diff --git a/test/mppa/prng/prng.h b/test/mppa/prng/prng.h deleted file mode 100644 index 6abdb45a..00000000 --- a/test/mppa/prng/prng.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef __PRNG_H__ -#define __PRNG_H__ - -#include "types.h" - -void srand(uint64_t seed); - -uint64_t randlong(void); - -#endif // __PRNG_H__ diff --git a/test/mppa/prng/types.h b/test/mppa/prng/types.h deleted file mode 100644 index 584023e3..00000000 --- a/test/mppa/prng/types.h +++ /dev/null @@ -1,7 +0,0 @@ -#ifndef __TYPES_H__ -#define __TYPES_H__ - -#define uint64_t unsigned long long -#define int64_t signed long long - -#endif // __TYPES_H__ diff --git a/test/mppa/simucheck.sh b/test/mppa/simucheck.sh deleted file mode 100755 index 48698e35..00000000 --- a/test/mppa/simucheck.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -# Tests the execution of the binaries produced by CompCert, by simulation - -cores=$(grep -c ^processor /proc/cpuinfo) - -source do_test.sh - -do_test check $cores diff --git a/test/mppa/simutest.sh b/test/mppa/simutest.sh deleted file mode 100755 index 729d1ba0..00000000 --- a/test/mppa/simutest.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash -# Tests the validity of the tests, in simulator - -cores=$(grep -c ^processor /proc/cpuinfo) - -source do_test.sh - -do_test test $cores diff --git a/test/mppa/sort/.gitignore b/test/mppa/sort/.gitignore deleted file mode 100644 index 070b87c4..00000000 --- a/test/mppa/sort/.gitignore +++ /dev/null @@ -1,9 +0,0 @@ -main-test-ccomp-kvx -main-test-gcc-kvx -main-test-gcc-x86 -merge-test-gcc-kvx -merge-test-gcc-x86 -selection-test-gcc-kvx -selection-test-gcc-x86 -insertion-test-gcc-kvx -insertion-test-gcc-x86 diff --git a/test/mppa/sort/Makefile b/test/mppa/sort/Makefile deleted file mode 100644 index c4090352..00000000 --- a/test/mppa/sort/Makefile +++ /dev/null @@ -1,91 +0,0 @@ -KVXC ?= k1-cos-gcc -CC ?= gcc -CCOMP ?= ccomp -CFLAGS ?= -O2 -SIMU ?= k1-mppa -TIMEOUT ?= 10s - -KVXCPATH=$(shell which $(KVXC)) -CCPATH=$(shell which $(CC)) -CCOMPPATH=$(shell which $(CCOMP)) -SIMUPATH=$(shell which $(SIMU)) - -PRNG=../prng/prng.c - -CFILES=insertion.c merge.c selection.c main.c - -ALL= insertion-gcc-x86 insertion-gcc-kvx insertion-ccomp-kvx\ - selection-gcc-x86 selection-gcc-kvx selection-ccomp-kvx\ - merge-gcc-x86 merge-gcc-kvx merge-ccomp-kvx\ - main-gcc-x86 main-gcc-kvx main-ccomp-kvx - -CCOMP_OUT= insertion-ccomp-kvx.out selection-ccomp-kvx.out merge-ccomp-kvx.out\ - main-ccomp-kvx.out -GCC_OUT= insertion-gcc-kvx.out selection-gcc-kvx.out merge-gcc-kvx.out\ - main-gcc-kvx.out -X86_GCC_OUT= insertion-gcc-x86.out selection-gcc-x86.out merge-gcc-x86.out\ - main-gcc-x86.out -STUB_OUT= .zero - -all: $(ALL) - -main-gcc-x86: $(CFILES) $(PRNG) $(CCPATH) - $(CC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -%-gcc-x86: %.c $(PRNG) $(CCPATH) - $(CC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -main-gcc-kvx: $(CFILES) $(PRNG) $(CCPATH) - $(KVXC) $(CFLAGS) $(filter-out $(CCPATH),$^) -o $@ - -%-gcc-kvx: %.c $(PRNG) $(KVXCPATH) - $(KVXC) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(KVXCPATH),$^) -o $@ - -main-ccomp-kvx: $(CFILES) $(PRNG) $(CCOMPPATH) - $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ - -%-ccomp-kvx: %.c $(PRNG) $(CCOMPPATH) - $(CCOMP) -D__UNIT_TEST_$$(echo $(basename $<) | tr a-z A-Z)__ $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@ - -.SECONDARY: -%x86.out: %x86 - ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@ - -%kvx.out: %kvx $(SIMUPATH) - ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@ - -.zero: - @echo "0" > $@ - -.PHONY: -test-x86: $(STUB_OUT) $(X86_GCC_OUT) - @for test in $(wordlist 2,100,$^); do\ - if ! diff $$test $(STUB_OUT); then\ - >&2 echo "ERROR x86: $$test failed";\ - else\ - echo "GOOD x86: $$test succeeded";\ - fi;\ - done - -.PHONY: -test-kvx: $(STUB_OUT) $(GCC_OUT) - @for test in $(wordlist 2,100,$^); do\ - if ! diff $$test $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $$test failed";\ - else\ - echo "GOOD kvx: $$test succeeded";\ - fi;\ - done - -.PHONY: -test: test-x86 test-kvx - -.PHONY: -check: $(STUB_OUT) $(CCOMP_OUT) - @for test in $(wordlist 2,100,$^); do\ - if ! diff $$test $(STUB_OUT); then\ - >&2 echo "ERROR kvx: $$test failed";\ - else\ - echo "GOOD kvx: $$test succeeded";\ - fi;\ - done diff --git a/test/mppa/sort/README.md b/test/mppa/sort/README.md deleted file mode 100644 index 98ed539d..00000000 --- a/test/mppa/sort/README.md +++ /dev/null @@ -1,17 +0,0 @@ -PRNG -==== - -This is a simple Pseudo Random Number Generator. - -`prng.c` contains a simple unitary test that compares the sum of the "bytewise sum" -of 1000 generated numbers to a hardcoded result, that is the one obtained with -`gcc -O2` on a x86 processor, and returns 0 if the result is correct. - -The following commands can be run inside that folder: - -- `make`: produces the unitary test binaries - - `prng-test-gcc-x86` : binary from gcc on x86 - - `prng-test-kvx-x86` : binary from gcc on kvx - - `prng-test-ccomp-x86` : binary from ccomp on kvx -- `make test`: tests the return value of the binaries produced by gcc. -- `make check`: tests the return value of the binary produced by CompCert. diff --git a/test/mppa/sort/insertion.c b/test/mppa/sort/insertion.c deleted file mode 100644 index bca09599..00000000 --- a/test/mppa/sort/insertion.c +++ /dev/null @@ -1,59 +0,0 @@ -#include "../prng/prng.h" -#include "../prng/types.h" - -#ifdef __UNIT_TEST_INSERTION__ -#define SIZE 100 -#else -#include "test.h" -#endif - -void swap_ins(uint64_t *a, uint64_t *b){ - uint64_t tmp = *a; - *a = *b; - *b = tmp; -} - -int insert_sort(uint64_t *res, const uint64_t *T){ - int i, j; - - if (SIZE <= 0) - return -1; - - for (i = 0 ; i < SIZE ; i++) - res[i] = T[i]; - - for (i = 0 ; i < SIZE-1 ; i++){ - if (res[i] > res[i+1]){ - swap_ins(&res[i], &res[i+1]); - for (j = i ; j > 0 ; j--) - if (res[j-1] > res[j]) - swap_ins(&res[j-1], &res[j]); - } - } - - return 0; -} - -#ifdef __UNIT_TEST_INSERTION__ -int main(void){ - uint64_t T[SIZE]; - uint64_t res[SIZE]; - int i; - srand(42); - - for (i = 0 ; i < SIZE ; i++) - T[i] = randlong(); - - /* Sorting the table */ - if (insert_sort(res, T) < 0) return -1; - - /* Computing max(T) */ - uint64_t max = T[0]; - for (i = 1 ; i < SIZE ; i++) - if (T[i] > max) - max = T[i]; - - /* We should have: max(T) == res[SIZE] */ - return !(max == res[SIZE-1]); -} -#endif // __UNIT_TEST_INSERTION__ diff --git a/test/mppa/sort/insertion.h b/test/mppa/sort/insertion.h deleted file mode 100644 index 6e37c5fe..00000000 --- a/test/mppa/sort/insertion.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __INSERTION_H__ -#define __INSERTION_H__ - -int insert_sort(uint64_t *res, const uint64_t *T); - -#endif // __INSERTION_H__ diff --git a/test/mppa/sort/main.c b/test/mppa/sort/main.c deleted file mode 100644 index aef419aa..00000000 --- a/test/mppa/sort/main.c +++ /dev/null @@ -1,34 +0,0 @@ -#include "../prng/prng.h" -#include "../prng/types.h" - -#include "test.h" -#include "insertion.h" -#include "selection.h" -#include "merge.h" - -int main(void){ - uint64_t T[SIZE]; - uint64_t res1[SIZE], res2[SIZE], res3[SIZE]; - int i; - srand(42); - - for (i = 0 ; i < SIZE ; i++) - T[i] = randlong(); - - /* insertion sort */ - if (insert_sort(res1, T) < 0) return -1; - - /* selection sort */ - if (select_sort(res2, T) < 0) return -2; - - /* merge sort */ - if (merge_sort(res3, T) < 0) return -3; - - /* We should have: res1[i] == res2[i] == res3[i] */ - for (i = 0 ; i < SIZE ; i++){ - if (!(res1[i] == res2[i] && res2[i] == res3[i])) - return -4; - } - - return 0; -} diff --git a/test/mppa/sort/merge.c b/test/mppa/sort/merge.c deleted file mode 100644 index 99f8ba85..00000000 --- a/test/mppa/sort/merge.c +++ /dev/null @@ -1,92 +0,0 @@ -#include "../prng/prng.h" -#include "../prng/types.h" - -//https://en.wikipedia.org/wiki/Merge_sort - -#ifdef __UNIT_TEST_MERGE__ -#define SIZE 100 -#else -#include "test.h" -#endif - -int min(int a, int b){ - return (a < b)?a:b; -} - -void BottomUpMerge(const uint64_t *A, int iLeft, int iRight, int iEnd, uint64_t *B) -{ - int i = iLeft, j = iRight, k; - for (k = iLeft; k < iEnd; k++) { - if (i < iRight && (j >= iEnd || A[i] <= A[j])) { - B[k] = A[i]; - i = i + 1; - } else { - B[k] = A[j]; - j = j + 1; - } - } -} - -void CopyArray(uint64_t *to, const uint64_t *from) -{ - const int n = SIZE; - int i; - - for(i = 0; i < n; i++) - to[i] = from[i]; -} - -void BottomUpMergeSort(uint64_t *A, uint64_t *B) -{ - const int n = SIZE; - int width, i; - - for (width = 1; width < n; width = 2 * width) - { - for (i = 0; i < n; i = i + 2 * width) - { - BottomUpMerge(A, i, min(i+width, n), min(i+2*width, n), B); - } - CopyArray(A, B); - } -} - -int merge_sort(uint64_t *res, const uint64_t *T){ - int i; - - if (SIZE <= 0) - return -1; - - uint64_t B[SIZE]; - uint64_t *A = res; - for (i = 0 ; i < SIZE ; i++) - A[i] = T[i]; - - BottomUpMergeSort(A, B); - - return 0; -} - -#ifdef __UNIT_TEST_MERGE__ -int main(void){ - uint64_t T[SIZE]; - uint64_t res[SIZE]; - int i; - srand(42); - - for (i = 0 ; i < SIZE ; i++) - T[i] = randlong(); - - /* Sorting the table */ - if (merge_sort(res, T) < 0) return -1; - - /* Computing max(T) */ - uint64_t max = T[0]; - for (i = 1 ; i < SIZE ; i++) - if (T[i] > max) - max = T[i]; - - /* We should have: max(T) == res[SIZE] */ - return !(max == res[SIZE-1]); -} -#endif // __UNIT_TEST_MERGE__ diff --git a/test/mppa/sort/merge.h b/test/mppa/sort/merge.h deleted file mode 100644 index 439ce64a..00000000 --- a/test/mppa/sort/merge.h +++ /dev/null @@ -1,7 +0,0 @@ -#ifndef __MERGE_H__ -#define __MERGE_H__ - -int merge_sort(uint64_t *res, const uint64_t *T); - -#endif // __MERGE_H__ - diff --git a/test/mppa/sort/selection.c b/test/mppa/sort/selection.c deleted file mode 100644 index df4be04f..00000000 --- a/test/mppa/sort/selection.c +++ /dev/null @@ -1,62 +0,0 @@ -#include "../prng/prng.h" -#include "../prng/types.h" - -#ifdef __UNIT_TEST_SELECTION__ -#define SIZE 100 -#else -#include "test.h" -#endif - -void swap_sel(uint64_t *a, uint64_t *b){ - uint64_t tmp = *a; - *a = *b; - *b = tmp; -} - -int select_sort(uint64_t *res, const uint64_t *T){ - int i, j, iMin; - - if (SIZE <= 0) - return -1; - - for (i = 0 ; i < SIZE ; i++) - res[i] = T[i]; - - for (j = 0 ; j < SIZE ; j++){ - iMin = j; - for (i = j+1 ; i < SIZE ; i++) - if (res[i] < res[iMin]) - iMin = i; - - if (iMin != j) - swap_sel (&res[j], &res[iMin]); - } - - return 0; -} - -#ifdef __UNIT_TEST_SELECTION__ -int main(void){ - uint64_t T[SIZE]; - uint64_t res[SIZE]; - uint64_t max; - int i; - srand(42); - - for (i = 0 ; i < SIZE ; i++) - T[i] = randlong(); - - /* Sorting the table */ - if (select_sort(res, T) < 0) return -1; - - /* Computing max(T) */ - max = T[0]; - for (i = 1 ; i < SIZE ; i++) - if (T[i] > max) - max = T[i]; - - /* We should have: max(T) == res[SIZE] */ - return !(max == res[SIZE-1]); -} -#endif // __UNIT_TEST_SELECTION__ - diff --git a/test/mppa/sort/selection.h b/test/mppa/sort/selection.h deleted file mode 100644 index 92a6b461..00000000 --- a/test/mppa/sort/selection.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __SELECTION_H__ -#define __SELECTION_H__ - -int select_sort(uint64_t *res, const uint64_t *T); - -#endif // __SELECTION_H__ diff --git a/test/mppa/sort/test.h b/test/mppa/sort/test.h deleted file mode 100644 index 4501ee38..00000000 --- a/test/mppa/sort/test.h +++ /dev/null @@ -1,6 +0,0 @@ -#ifndef __TEST_H__ -#define __TEST_H__ - -#define SIZE 100 - -#endif diff --git a/test/regression/builtins-kvx.c b/test/regression/builtins-kvx.c new file mode 100644 index 00000000..cbf51387 --- /dev/null +++ b/test/regression/builtins-kvx.c @@ -0,0 +1,72 @@ +/* Fun with builtins */ + +#include +#include + +char * check_relative_error(double exact, double actual, double precision) +{ + double relative_error = (actual - exact) / exact; + return fabs(relative_error) <= precision ? "OK" : "ERROR"; +} + +//unsigned int x = 0x12345678; +//unsigned int y = 0xDEADBEEF; +//unsigned long long xx = 0x1234567812345678ULL; +//double a = 3.14159; +//double b = 2.718; +//double c = 1.414; +//unsigned short s = 0x1234; + +int main(int argc, char ** argv) +{ + unsigned z; + + //printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y)); + //printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y)); + //printf("clz(%x) = %d\n", x, __builtin_clz(x)); + //printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); + //printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); + //z = __builtin_bswap(x); + //printf("clzll(%lx) = %d\n", z, __builtin_clzll(z)); + //printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); + //printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); + + //printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c)); + //printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c)); + //printf("fabs(%f) = %f\n", a, __builtin_fabs(a)); + //printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a)); + //printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); + //printf("frsqrte(%f) = %s\n", + // a, check_relative_error(1.0 / sqrt(a), __builtin_frsqrte(a), 1./32.)); + //printf("fres(%f) = %s\n", + // a, check_relative_error(1.0 / a, __builtin_fres(a), 1./256.)); + //printf("fsel(%f, %f, %f) = %f\n", a, b, c, __builtin_fsel(a, b, c)); + //printf("fsel(%f, %f, %f) = %f\n", -a, b, c, __builtin_fsel(-a, b, c)); + //printf("fcti(%f) = %d\n", a, __builtin_fcti(a)); + //printf("fcti(%f) = %d\n", b, __builtin_fcti(b)); + //printf("fcti(%f) = %d\n", c, __builtin_fcti(c)); + //__builtin_eieio(); + //__builtin_sync(); + //__builtin_isync(); + //printf("isel(%d, %d, %d) = %d\n", 0, x, y, __builtin_isel(0, x, y)); + //printf("isel(%d, %d, %d) = %d\n", 42, x, y, __builtin_isel(42, x, y)); + //printf ("read_16_rev = %x\n", __builtin_read16_reversed(&s)); + //printf ("read_32_rev = %x\n", __builtin_read32_reversed(&y)); + //__builtin_write16_reversed(&s, 0x789A); + //printf ("after write_16_rev: %x\n", s); + //__builtin_write32_reversed(&y, 0x12345678); + //printf ("after write_32_rev: %x\n", y); + //y = 0; + //__builtin_write32_reversed(&y, 0x12345678); + //printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR"); + ///* Make sure that ignoring the result of a builtin + // doesn't cause an internal error */ + //(void) __builtin_bswap(x); + //(void) __builtin_fsqrt(a); + return 0; +} + + + + + diff --git a/test/regression/builtins-mppa_k1c.c b/test/regression/builtins-mppa_k1c.c deleted file mode 100644 index cbf51387..00000000 --- a/test/regression/builtins-mppa_k1c.c +++ /dev/null @@ -1,72 +0,0 @@ -/* Fun with builtins */ - -#include -#include - -char * check_relative_error(double exact, double actual, double precision) -{ - double relative_error = (actual - exact) / exact; - return fabs(relative_error) <= precision ? "OK" : "ERROR"; -} - -//unsigned int x = 0x12345678; -//unsigned int y = 0xDEADBEEF; -//unsigned long long xx = 0x1234567812345678ULL; -//double a = 3.14159; -//double b = 2.718; -//double c = 1.414; -//unsigned short s = 0x1234; - -int main(int argc, char ** argv) -{ - unsigned z; - - //printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y)); - //printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y)); - //printf("clz(%x) = %d\n", x, __builtin_clz(x)); - //printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x)); - //printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx)); - //z = __builtin_bswap(x); - //printf("clzll(%lx) = %d\n", z, __builtin_clzll(z)); - //printf("bswap(%x) = %x\n", x, __builtin_bswap(x)); - //printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s)); - - //printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c)); - //printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c)); - //printf("fabs(%f) = %f\n", a, __builtin_fabs(a)); - //printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a)); - //printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a)); - //printf("frsqrte(%f) = %s\n", - // a, check_relative_error(1.0 / sqrt(a), __builtin_frsqrte(a), 1./32.)); - //printf("fres(%f) = %s\n", - // a, check_relative_error(1.0 / a, __builtin_fres(a), 1./256.)); - //printf("fsel(%f, %f, %f) = %f\n", a, b, c, __builtin_fsel(a, b, c)); - //printf("fsel(%f, %f, %f) = %f\n", -a, b, c, __builtin_fsel(-a, b, c)); - //printf("fcti(%f) = %d\n", a, __builtin_fcti(a)); - //printf("fcti(%f) = %d\n", b, __builtin_fcti(b)); - //printf("fcti(%f) = %d\n", c, __builtin_fcti(c)); - //__builtin_eieio(); - //__builtin_sync(); - //__builtin_isync(); - //printf("isel(%d, %d, %d) = %d\n", 0, x, y, __builtin_isel(0, x, y)); - //printf("isel(%d, %d, %d) = %d\n", 42, x, y, __builtin_isel(42, x, y)); - //printf ("read_16_rev = %x\n", __builtin_read16_reversed(&s)); - //printf ("read_32_rev = %x\n", __builtin_read32_reversed(&y)); - //__builtin_write16_reversed(&s, 0x789A); - //printf ("after write_16_rev: %x\n", s); - //__builtin_write32_reversed(&y, 0x12345678); - //printf ("after write_32_rev: %x\n", y); - //y = 0; - //__builtin_write32_reversed(&y, 0x12345678); - //printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR"); - ///* Make sure that ignoring the result of a builtin - // doesn't cause an internal error */ - //(void) __builtin_bswap(x); - //(void) __builtin_fsqrt(a); - return 0; -} - - - - - -- cgit From bcc21caefb5ec0a88706c428e205cedf6680ddaf Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 27 May 2020 08:07:39 +0200 Subject: CI for KVX --- .download_from_Kalray.sh | 7 +++++++ .gitlab-ci.yml | 12 ++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) create mode 100755 .download_from_Kalray.sh diff --git a/.download_from_Kalray.sh b/.download_from_Kalray.sh new file mode 100755 index 00000000..b82296da --- /dev/null +++ b/.download_from_Kalray.sh @@ -0,0 +1,7 @@ +#!/bin/sh +mkdir download +cd download +sshpass "-p$KALRAY_SFTP_PASSWORD" sftp compcert@ssh.kalray.eu < Date: Wed, 27 May 2020 08:12:16 +0200 Subject: strict key checking off --- .download_from_Kalray.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.download_from_Kalray.sh b/.download_from_Kalray.sh index b82296da..5e7dee24 100755 --- a/.download_from_Kalray.sh +++ b/.download_from_Kalray.sh @@ -1,7 +1,7 @@ #!/bin/sh mkdir download cd download -sshpass "-p$KALRAY_SFTP_PASSWORD" sftp compcert@ssh.kalray.eu < Date: Wed, 27 May 2020 08:24:50 +0200 Subject: download/untar from Kalray --- .download_from_Kalray.sh | 3 ++- .gitlab-ci.yml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.download_from_Kalray.sh b/.download_from_Kalray.sh index 5e7dee24..a7f28d5a 100755 --- a/.download_from_Kalray.sh +++ b/.download_from_Kalray.sh @@ -1,7 +1,8 @@ #!/bin/sh mkdir download cd download -sshpass "-p$KALRAY_SFTP_PASSWORD" sftp -v -o "StrictHostKeyChecking=no" compcert@ssh.kalray.eu < Date: Wed, 27 May 2020 08:33:36 +0200 Subject: install extra packages --- .gitlab-ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8d12406a..5ebdab54 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -225,9 +225,9 @@ build_kvx: image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update - - sudo apt-get -y install sshpass openssh-client + - sudo apt-get -y install sshpass openssh-client libzip4 lttng-tools liblttng-ctl-dev liblttng-ust-dev babeltrace - ./.download_from_Kalray.sh - - rm -f download/*dkms*.deb download/*eclipse*.deb download/*llvm*.deb + - rm -f download/*dkms*.deb download/*eclipse*.deb download/*llvm*.deb download/*board-mgmt* download/*oce-host* download/*pocl* - sudo dpkg -i download/*.deb - rm -rf download - opam switch 4.07.1+flambda -- cgit From 4b7dc067af57e6aa917e54f39219ede3e447dd71 Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 27 May 2020 08:41:51 +0200 Subject: opam update --- .gitlab-ci.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5ebdab54..22cbce98 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -7,6 +7,7 @@ check-admitted: before_script: - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_x86_64.sh @@ -26,6 +27,7 @@ build_x86_64: before_script: - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_x86_64.sh @@ -49,6 +51,7 @@ build_ia32: - sudo apt-get -y install gcc-multilib - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_ia32.sh @@ -72,6 +75,7 @@ build_aarch64: - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_aarch64.sh @@ -95,6 +99,7 @@ build_arm: - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_arm.sh @@ -119,6 +124,7 @@ build_armhf: - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_armhf.sh @@ -142,6 +148,7 @@ build_ppc: - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_ppc.sh @@ -163,6 +170,7 @@ build_ppc64: - sudo apt-get -y install gcc-powerpc64-linux-gnu - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_ppc64.sh @@ -184,6 +192,7 @@ build_rv64: - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_rv64.sh @@ -207,6 +216,7 @@ build_rv32: - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - ./config_rv32.sh -no-runtime-lib @@ -232,6 +242,7 @@ build_kvx: - rm -rf download - opam switch 4.07.1+flambda - eval `opam config env` + - opam update - opam install -y menhir script: - source /opt/kalray/accesscore/kalray.sh && ./config_kvx.sh -- cgit From dd11a51feb082c6b978c9a9a6cd09272116bdfae Mon Sep 17 00:00:00 2001 From: David Monniaux Date: Wed, 27 May 2020 10:33:16 +0200 Subject: readme --- README.md | 15 +++++++++++++++ README_Kalray.md | 4 ++-- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 250814b1..b4578c18 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,18 @@ features, installation instructions, using the compiler, etc), please refer to the [Web site](http://compcert.inria.fr/) and especially the [user's manual](http://compcert.inria.fr/man/). +## VERIMAG version +This is a special version with additions from Verimag and Kalray : + * Some general-purpose optimization phases (e.g. profiling). + * A backend for the KVX processor. + +The people responsible for this version are + * Sylvain Boulmé (Grenoble-INP, Verimag) + * David Monniaux (CNRS, Verimag) + * Cyril Six (Kalray) + +See also `README_Kalray.md` and `PROFILING.md`. + ## License CompCert is not free software. This non-commercial release can only be used for evaluation, research, educational and personal purposes. @@ -29,6 +41,7 @@ The CompCert verified compiler is Copyright Institut National de Recherche en Informatique et en Automatique (INRIA) and AbsInt Angewandte Informatik GmbH. +The additions are Copyright Grenoble-INP, CNRS and Kalray. ## Contact General discussions on CompCert take place on the @@ -37,3 +50,5 @@ mailing list. For inquiries on the commercial version of CompCert, please contact info@absint.com + +For inquiries on the Verimag-specific additions, contact the researchers. diff --git a/README_Kalray.md b/README_Kalray.md index c6509597..7dba03dd 100644 --- a/README_Kalray.md +++ b/README_Kalray.md @@ -27,6 +27,6 @@ make make test ``` -The reference files were generated using `k1-cos-gcc -O1`. +The reference files were generated using `kvx-cos-gcc -O1`. -We also have our own tests in `test/mppa/` - to run them, execute the script `simucheck.sh` located in that folder. These consist in comparing `compcert` output to `k1-cos-gcc` output. +We also have our own tests in `test/kvx/` - to run them, execute the script `simucheck.sh` located in that folder. These consist in comparing `compcert` output to `kvx-cos-gcc` output. -- cgit From 564820f09022a93e8a50879d1fb558ac68e98f2a Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 15:37:52 +0200 Subject: replace k1 -> kvx --- INSTALL.md | 2 +- README_Kalray.md | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 4aaa431e..320191ce 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -40,7 +40,7 @@ Pre-compilation configure replace the placeholder with your desired platform ``` ./configure ``` -If using Kalray's platform, make sure that the k1 tools are on your path +If using Kalray's platform, make sure that the kvx tools are on your path Compile (adapt -j# to the number of cores and available RAM) ``` make -j12 diff --git a/README_Kalray.md b/README_Kalray.md index c6509597..7dba03dd 100644 --- a/README_Kalray.md +++ b/README_Kalray.md @@ -27,6 +27,6 @@ make make test ``` -The reference files were generated using `k1-cos-gcc -O1`. +The reference files were generated using `kvx-cos-gcc -O1`. -We also have our own tests in `test/mppa/` - to run them, execute the script `simucheck.sh` located in that folder. These consist in comparing `compcert` output to `k1-cos-gcc` output. +We also have our own tests in `test/kvx/` - to run them, execute the script `simucheck.sh` located in that folder. These consist in comparing `compcert` output to `kvx-cos-gcc` output. -- cgit From 2e1eedc4d3ec36c70eb591897d1851e2a9190294 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 15:54:55 +0200 Subject: link to the HAL preprint --- doc/index-kvx.html | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/index-kvx.html b/doc/index-kvx.html index ae01d2d6..1a206014 100644 --- a/doc/index-kvx.html +++ b/doc/index-kvx.html @@ -25,14 +25,18 @@ a:active {color : Red; text-decoration : underline; }

    The CompCert verified compiler

    Commented Coq development

    Version 3.7, 2020-03-31

    -

    PATCHED for the Kalray MPPA-KVX VLIW CORE

    +

    PATCHED for the Kalray MPPA-KVX VLIW CORE (2020-05-27)

    Introduction

    This web page is a patched version of the table of contents of the official CompCert documentation, as given on the CompCert Web site. The unmodified parts of this table appear in gray. - +
    +
    + A high-level view of this backend of CompCert is provided by this HAL preprint of Six, Boulmé and Monniaux (2019): + Certified Compiler Backends for VLIW Processors (Highly Modular Postpass-Scheduling in the CompCert Certified Compiler). +

    Table of contents

    -- cgit From 24d07a9c9b69fdeeeedba8a983b46667ae567a3f Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 18:26:22 +0200 Subject: basic pages configuration --- .gitlab-ci.yml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 22cbce98..0c8ee3cc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -257,3 +257,12 @@ build_kvx: - if: '$CI_COMMIT_BRANCH == "master"' when: always - when: manual + +pages: + stage: build + script: + - cp -r doc/* public/ + - mv public/index-kvx.html public/index.html + artifacts: + paths: + - public -- cgit From a510c89c9e96e1e967fcca5f35aa99f8ce3ded4d Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 18:36:22 +0200 Subject: fix pages ? --- .gitlab-ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0c8ee3cc..665d75d1 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -261,6 +261,7 @@ build_kvx: pages: stage: build script: + - mkdir public - cp -r doc/* public/ - mv public/index-kvx.html public/index.html artifacts: -- cgit From 6b22c8b89ca256430aea4f95ba8c8e84489f4685 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 18:50:11 +0200 Subject: pages: make documentation --- .gitlab-ci.yml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 665d75d1..f6308781 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -259,8 +259,12 @@ build_kvx: - when: manual pages: - stage: build + inherit: + build_kvx: [image before_script] + stage: build # TODO: change to "deploy" when "build" succeeds script: + - source /opt/kalray/accesscore/kalray.sh && ./config_kvx.sh + - source /opt/kalray/accesscore/kalray.sh && make -j "$NJOBS" documentation - mkdir public - cp -r doc/* public/ - mv public/index-kvx.html public/index.html -- cgit From 9473c1fae4f1421666d9862fa16a26de182bcdf4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 18:53:19 +0200 Subject: gitlab-ci.yml: inherit keyword does not work ? --- .gitlab-ci.yml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f6308781..7bb51ff2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -259,9 +259,19 @@ build_kvx: - when: manual pages: - inherit: - build_kvx: [image before_script] stage: build # TODO: change to "deploy" when "build" succeeds + image: "coqorg/coq" + before_script: + - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update + - sudo apt-get -y install sshpass openssh-client libzip4 lttng-tools liblttng-ctl-dev liblttng-ust-dev babeltrace + - ./.download_from_Kalray.sh + - rm -f download/*dkms*.deb download/*eclipse*.deb download/*llvm*.deb download/*board-mgmt* download/*oce-host* download/*pocl* + - sudo dpkg -i download/*.deb + - rm -rf download + - opam switch 4.07.1+flambda + - eval `opam config env` + - opam update + - opam install -y menhir script: - source /opt/kalray/accesscore/kalray.sh && ./config_kvx.sh - source /opt/kalray/accesscore/kalray.sh && make -j "$NJOBS" documentation -- cgit From aa78d4a8f9621d67dedc78ce5670b808eb2ef2c3 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 19:13:58 +0200 Subject: add coq2html for pages --- .gitlab-ci.yml | 2 ++ README_Kalray.md | 5 +++++ 2 files changed, 7 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7bb51ff2..442b56e0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -272,6 +272,8 @@ pages: - eval `opam config env` - opam update - opam install -y menhir + - opam repo add coq-released https://coq.inria.fr/opam/released + - opam install coq-coq2html script: - source /opt/kalray/accesscore/kalray.sh && ./config_kvx.sh - source /opt/kalray/accesscore/kalray.sh && make -j "$NJOBS" documentation diff --git a/README_Kalray.md b/README_Kalray.md index 7dba03dd..86c49ad1 100644 --- a/README_Kalray.md +++ b/README_Kalray.md @@ -16,6 +16,11 @@ This delivery contains (in addition to features from CompCert master branch): Please follow the instructions in `INSTALL.md` +## Documentation of the Coq sources + +The documentation is available [online](https://certicompil.gricad-pages.univ-grenoble-alpes.fr/compcert-kvx). +You may also generate it locally from `make documentation` (after installation via `INSTALL.md`): the entry-point is in `doc/index-kvx.html`. + ## Testing We modified most of the CompCert tests of the `c` folder in order for them to be executable in reasonable time by the simulator. -- cgit From 71cd960e0cf7d54fd6dfac59230b520c75fd3c92 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 19:37:53 +0200 Subject: fix pages ? --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 442b56e0..9c255aa6 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -276,7 +276,8 @@ pages: - opam install coq-coq2html script: - source /opt/kalray/accesscore/kalray.sh && ./config_kvx.sh - - source /opt/kalray/accesscore/kalray.sh && make -j "$NJOBS" documentation + - source /opt/kalray/accesscore/kalray.sh && make -j "$NJOBS" + - source /opt/kalray/accesscore/kalray.sh && make documentation - mkdir public - cp -r doc/* public/ - mv public/index-kvx.html public/index.html -- cgit From a1358ff333c840ac0ac447d6f55d64cc7d077cc4 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Wed, 27 May 2020 20:40:39 +0200 Subject: source url in the doc --- .gitlab-ci.yml | 3 +++ doc/index-kvx.html | 6 ++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9c255aa6..971034bc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -284,3 +284,6 @@ pages: artifacts: paths: - public + rules: + - if: '$CI_COMMIT_BRANCH == "master"' + when: always diff --git a/doc/index-kvx.html b/doc/index-kvx.html index 1a206014..4660c1d1 100644 --- a/doc/index-kvx.html +++ b/doc/index-kvx.html @@ -34,8 +34,10 @@ a:active {color : Red; text-decoration : underline; } The unmodified parts of this table appear in gray.

    - A high-level view of this backend of CompCert is provided by this HAL preprint of Six, Boulmé and Monniaux (2019): - Certified Compiler Backends for VLIW Processors (Highly Modular Postpass-Scheduling in the CompCert Certified Compiler). + A high-level view of this backend of CompCert is provided by this HAL preprint of Six, Boulmé and Monniaux (2019): + +
    + Our source code is available on our GitLab public repository (see conditions in the LICENSE file).

    Table of contents

    -- cgit From e7fad4516e0e7705480312caa427e838f3321948 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 28 May 2020 07:27:46 +0200 Subject: automatic date in the html index --- .gitlab-ci.yml | 7 ++++--- doc/index-kvx.html | 2 +- tools/fix_html_date.sh | 8 ++++++++ 3 files changed, 13 insertions(+), 4 deletions(-) create mode 100755 tools/fix_html_date.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 971034bc..0499abc2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -258,8 +258,8 @@ build_kvx: when: always - when: manual -pages: - stage: build # TODO: change to "deploy" when "build" succeeds +pages: # TODO: change to "deploy" when "build" succeeds (or integrate with "build_kvx" above ?) + stage: build image: "coqorg/coq" before_script: - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update @@ -280,7 +280,8 @@ pages: - source /opt/kalray/accesscore/kalray.sh && make documentation - mkdir public - cp -r doc/* public/ - - mv public/index-kvx.html public/index.html + - tools/fix_html_date.sh doc/index-kvx.html " (" ")" > public/index.html + - rm public/index-kvx.html artifacts: paths: - public diff --git a/doc/index-kvx.html b/doc/index-kvx.html index 4660c1d1..95fdb6de 100644 --- a/doc/index-kvx.html +++ b/doc/index-kvx.html @@ -25,7 +25,7 @@ a:active {color : Red; text-decoration : underline; }

    The CompCert verified compiler

    Commented Coq development

    Version 3.7, 2020-03-31

    -

    PATCHED for the Kalray MPPA-KVX VLIW CORE (2020-05-27)

    +

    PATCHED for the Kalray MPPA-KVX VLIW CORE

    Introduction

    diff --git a/tools/fix_html_date.sh b/tools/fix_html_date.sh new file mode 100755 index 00000000..c7fbdabe --- /dev/null +++ b/tools/fix_html_date.sh @@ -0,0 +1,8 @@ +#!/bin/bash +# +# Replace an HTML comment "" by the current date +# in the file given by $1 (with $2 as prefix and $3 as suffix) +# +# Result on standard output + +sed -e "s//$2$(date +'%F')$3/g" $1 -- cgit From 17c564cb99076eb0e2b34eeed4f24a18febe7116 Mon Sep 17 00:00:00 2001 From: Sylvain Boulmé Date: Thu, 28 May 2020 11:46:07 +0200 Subject: fix markdown --- README.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index b4578c18..59ff7447 100644 --- a/README.md +++ b/README.md @@ -18,15 +18,17 @@ the [user's manual](http://compcert.inria.fr/man/). ## VERIMAG version This is a special version with additions from Verimag and Kalray : + * Some general-purpose optimization phases (e.g. profiling). * A backend for the KVX processor. The people responsible for this version are + * Sylvain Boulmé (Grenoble-INP, Verimag) * David Monniaux (CNRS, Verimag) * Cyril Six (Kalray) -See also `README_Kalray.md` and `PROFILING.md`. +See also `README_Kalray.md` and `PROFILING.md` and [the online documentation](https://certicompil.gricad-pages.univ-grenoble-alpes.fr/compcert-kvx). ## License CompCert is not free software. This non-commercial release can only -- cgit